I'm generating a "random" (with no repeats) list of the questions using the following:
Sub randomCollection()
Dim Names As New Collection
Dim lastRow As Long, i As Long, j As Long, lin As Long
Dim wk As Worksheet
Set wk = Sheets("Sheet1")
With wk
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To lastRow
Names.Add wk.Cells(i, 1).Value, CStr(wk.Cells(i, 1).Value)
Next i
lin = 1
For i = lastRow - 1 To 1 Step -1
j = Application.WorksheetFunction.RandBetween(1, i)
lin = lin + 1
Range("B" & lin) = Names(j)
Names.Remove j
Next i
End Sub
I'm stuck on how to pick up data in column B, and generate it with the corresponding data in column A.
For example, A1 and B1 need to stay together on the "random" list, as does A2, B2, etc.
If I understand your task correctly, you want to take whatever is in column A and put it in column B in random locations, not including a header row. If this is the case, try this:
Sub randomCollection()
Dim wrk As Worksheet, source As Long, dest As Long, lastRow As Long, i As Long, rowCount As Long
Set wrk = ActiveWorkbook.ActiveSheet
lastRow = wrk.Rows.Count
lastRow = wrk.Range("A1:A" & Trim(Str(lastRow))).End(xlDown).Row
'First, clear out the destination range
wrk.Range("B2:B" + Trim(Str(lastRow))).Clear
source = 2
Do Until source > lastRow
dest = Application.WorksheetFunction.RandBetween(1, lastRow - source + 1)
'Find the blank row corresponding to it
rowCount = 1
For i = 2 To lastRow
If dest = rowCount And wrk.Cells(i, 2) = "" Then
wrk.Cells(i, 2) = wrk.Cells(source, 1)
Exit For
End If
If wrk.Cells(i, 2) = "" Then '2 is column B
rowCount = rowCount + 1
End If
Next
source = source + 1
Loop
End Sub
This looks for the first random blank space in column B to put each cell in column A.
Related
I have a column "F" in workbook1 containing some values (obtained after using some excel formulas to extract and concatenate from other columns) like
blah-rd1
blah-rd5
blah-rd6
blah-rd48do I want to do this
blah-rd100
etc
I have another column "D" in workbook2 containing values like
rndm-blah-rd1_sgjgs
hjdf-blah-rd5_cnnv
sdfhjdf-blah-rd100_cfdnnv
ect
Basically "Blah-rdxx" is always present alongwith other strings in D column of workbook2
Now, what I want to do is -
If value in D column of workbook2 contains value of F column of workbook1 Then
copy corresponding value of S column of workbook2 in H column of workbook1 (5th column)
This is where I have reached so far but it doesnt copy anything probably coz there is some problem and the outer loop is not iterating, I tried following solution Nested For Next Loops: Outer loop not iterating and added n counter but still outer loop doesn't iterate -
Sub findandcopy()
Dim r As Range
Dim f As Range
Dim i As Long
Dim j As Long
Dim w1 As Worksheet
Dim w2 As Worksheet
Dim n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
w2.Cells(i, 2).Copy (w2.Cells(j, 5))
Exit For
n = n + 1
End If
Next j
Next i
End Sub
Try this
Option Explicit
Public Sub FindAndCopy()
Const F = "F"
Const D = "D"
Const H = 2
Const S = 15
Dim ws1 As Worksheet: Set ws1 = Workbooks("Book1.xlsm").Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Workbooks("Book2.xlsm").Worksheets("Sheet1")
Dim lr1 As Long: lr1 = ws1.Cells(ws1.Rows.Count, F).End(xlUp).Row
Dim lr2 As Long: lr2 = ws2.Cells(ws2.Rows.Count, D).End(xlUp).Row
Dim itm1 As Range, itm2 As Range
Application.ScreenUpdating = False
For Each itm2 In ws2.Range(ws2.Cells(1, D), ws2.Cells(lr2, D)) 'Book2
For Each itm1 In ws1.Range(ws1.Cells(1, F), ws1.Cells(lr1, F)) 'Book1
If Not IsError(itm1) And Not IsError(itm2) Then
If InStr(1, itm2.Value2, itm1.Value2) > 0 Then
itm1.Offset(, H).Formula = itm2.Offset(, S).Formula 'Book1.H = Book2.S
Exit For
End If
End If
Next
Next
Application.ScreenUpdating = True
End Sub
The original code, with explanations of functional issues:
Sub findandcopy()
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, n As Integer
Set w1 = Workbooks("Book1.xlsm").Worksheets("sheet1")
Set w2 = Workbooks("Book2.xlsx").Worksheets("sheet1")
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row 'for each used cell in w2.colA
For j = 1 To w1.Cells(Rows.Count, 1).End(xlUp).Row + n 'for each used cell in w1.colA
'Find the text from w1.colC (current w1 row), within cell in w2.colA (current w2 row)
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
'If found then copy cell in w2.colB into cell in w2.colE (current w2 row)
w2.Cells(i, 2).Copy (w2.Cells(i, 5))
Exit For 'this exits the inner For loop
n = n + 1 'this would jump over the next cell(s) in w1, but never executes
End If
Next j
Next i
End Sub
The missing indentation makes it hard to follow
There are unused variables (r, f), and w1 / w2 names can mean Workbook, or Worksheet
"Option Explicit" should be used at the top of every module
The code doesn't handle cells with errors
#N/A, #VALUE!, #REF!, #DIV/0!, #NUM!, #NAME?, or #NULL!
If you'd like a more detailed review of the code, once it's fixed you can post it on Code Review
The idea behind this is to use vba vlookup on column G:AI from sheet11-13 to sheet1. Header ends at row 3 across all worksheets.
I have written the codes as below. The code stops at the ws1.Cells(r, c).Value = Application.WorksheetFunction.VLookup(ws1.Cells(r, 1).Value, ws2.Range("A1:AI500"), colnum, False) showing subset out of range and sometimes even
Run-time error '1004': Unable to get the VLookup property of the WorksheetFunction class.
Please advice on the way forward.
I Would like to send out files for better clarification but can't seem to find the attach function. Thank you !
Sub green_update()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet13")
Dim bil As String
Dim lastrow As Long
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
'mysheets = "sheet11:sheet12:sheet13"
'i would like to allow vlookup to search through all sheet 11-13
For for_col = 1 To ws2.Cells("4", Columns.Count).End(xlToLeft).column
lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).row
For i = 1 To lastrow - 3
ws1.Cells(r, c).Value = Application.WorksheetFunction.VLookup(ws1.Cells(r, 1).Value, ws2.Range("A1:AI500"), colnum, False)
r = r + 1
Next
r = 4
colnum = colnum + 1
c = c + 1
Next
End Sub
As you have totally changed what you were asking.. I am posting another answer to make it clear.
Still your request is not totally clear so that some inputs may refer to wrong destinations but you can change those ones easily.
If you don't understand any part feel free to ask it again.
Option Explicit
Sub green_update()
Application.ScreenUpdating = False
Dim zaman As Double
zaman = Timer
Dim wb As Workbook, ws1 As Worksheet, wsNames as Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Dim colNo As Long, OthARowNo As Long, sh1ARowNo As Long
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
For Each wsNames In Sheets(Array("sheet11", "sheet12", "sheet13"))
colNo = wsNames.Cells("4", Columns.Count).End(xlToLeft).column
'Column numbers are 35 but you are working between G:AI which is 29 columns!
OthARowNo = wsNames.Cells(Rows.Count, "A").End(xlUp).row
sh1ARowNo = ws1.Cells(Rows.Count, "A").End(xlUp).row
For for_col = 7 To colNo 'colNo Is 35 Green columns start at 7th column, totally 29 loop, till 35th one.
For i = 1 To sh1ARowNo 'This should run until sh1's row number
ws1.Cells(r, c).Value = Application.VLookup(ws1.Cells(r, 1).Value, wsNames.Range("A1:AI" & OthARowNo), colnum, False)
If IsError(ws1.Cells(r, c).Value) Then
ws1.Cells(r, c).Value = ""
End If
r = r + 1
Next i
r = 4
colnum = colnum + 1
c = c + 1
Next for_col
colnum = 7
c = c + 6 'There are 6 columns between AI:AP and BR:BY
Next wsNames
Application.ScreenUpdating = True
MsgBox Format(Timer - zaman, "00.00") & "secs"
End Sub
I explained my answer within the code, but to summarize your problems:
1- You don't define your variables, especially worksheets. Never Assume your worksheet and always define and set references to Workbooks and Worksheets
2- You are limiting your For loops with the Row number of A column and Column number of 3rd row, but what if they are empty or not compatible with your lookup rounds? Then you may get error or wrong results. Define them carefully.
Option Explicit
Sub green_update()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1") 'Change this Sheet1 name with your current Worksheet name
Set ws2 = wb.Sheets("mysheets")
Dim bil As String 'I don't know where do you use that variable.
Dim lastrow As Long 'Prefer to work with Long instead of Integer
Dim for_col As Long, i As Long, r As Long, c As Long, colnum As Long
r = 4: c = 7: colnum = 7
For for_col = 1 To ws2.Cells("4", Columns.Count).End(xlToLeft).Column
'This is important! Here in this case are you sure you, _
'you would like to define how many times your For loop will run based on 3rd row?
lastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
'This is also important! Are you sure you would like to run your For loop_
'based on the row number of A column? I think you should define it -3 _
'because you start your lookup from D4 (so first 3 one Is not necessary)
For i = 1 To lastrow - 3
ws1.Cells(r, c).Value = WorksheetFunction.VLookup(ws1.Cells(r, 4).Value, ws2.Range("A1:AI500"), colnum, False)
r = r + 1
Next
r = 4
colnum = colnum + 1
c = c + 1
Next
End Sub
I need help with this small project. What I need to accomplished this task is the following:
I have a excel file where my macro button once clicked will read the data from a sheet1 only in column A then should throw the data to another sheet2 and move every data from the sheet1 to sheet2 and display all the data to each separate column.
here is a image of the data example. in the image every circle needs to be in its own column to the new sheet2 that is only part of the data the total of the column rows is around 900.
if need more information please let me know.
here is the code I have it copy the sheet from sheet1 to sheet2 but I need the rest to work
Sub ExportFile()
Dim strValue As String
Dim strCellNum As String
Dim x As String
x = 1
For i = 1 To 700 Step 7
strCellNum = "A" & i
strValue = Worksheets("data").Range(strCellNum).Value
Debug.Print strValue
Worksheets("NewData").Range("A" & x).Value = strValue
x = x + 1
Next
End Sub
Give this a try:
Sub DataReorganizer()
Dim s1 As Worksheet, s2 As Worksheet, N As Long, i As Long, j As Long, k As Long
Dim v As Variant
Set s1 = Sheets("Data")
Set s2 = Sheets("NewData")
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 2 Step -1
If s1.Cells(i, "A").Value = "" And s1.Cells(i - 1, "A").Value = "" Then s1.Cells(i, "A").Delete shift:=xlUp
Next i
j = 1
k = 1
N = s1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = s1.Cells(i, "A").Value
If v = "" Then
j = 1
k = k + 1
Else
s2.Cells(j, k).Value = v
j = j + 1
End If
Next i
End Sub
you can try this:
Sub ExportFile()
Dim area As Range
Dim icol As Long
With Worksheets("data")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
For Each area In .Areas
icol = icol + 1
Worksheets("NewData").Cells(1, icol).Resize(area.Rows.Count).Value = area.Value
Next
End With
End With
End Sub
I have a loop towards the bottom of my code that successfully loops through my data and clears out all rows where Column H = 0.
However, there are several cells in column B displaying #REF!. I would also like this loop to delete those rows in the same manner as it does the 0s in column H.
I think my issue is not knowing how to reference those types of errors. Treating #REF! like a string doesn't appear to be working.
Thank you!
Sub test()
Dim currentSht As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim startCell As Range
Dim r As Integer
Set startCell = Sheets("Sheet1").Range("A1")
Set currentSht = ActiveWorkbook.Sheets("Sheet1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row '<~~ Not sure why, but do not use "Set" when defining lastRow
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For r = 1 To lastRow Step -1
If currentSht.Cells(r, "H").Value = 0 Or currentSht.Cells(r, "B").Text = "#REF!" Then
Rows(r).Select
Selection.EntireRow.Delete
End If
Next r
currentSht.Range(startCell, currentSht.Cells(lastRow, lastCol)).Select
End Sub
I think I see your problem:
For r = 1 To lastRow Step -1
Change that line to
For r = lastrow to 1 Step -1
How about this code:
Sub Delete0()
Dim F As Integer
Dim Y As Integer
Dim RngCount As Range
Set RngCount = ActiveSheet.Range("H:H")
Y = Application.WorksheetFunction.CountA(RngCount)
For F = Y To 1 Step -1
If IsError(ActiveSheet.Range("H" & F)) Then
ActiveSheet.Rows(F).EntireRow.Delete
ElseIf ActiveSheet.Range("H" & F).Value = 0 Then
ActiveSheet.Rows(F).EntireRow.Delete
End If
Next F
End Sub
I'm trying to write some VBA that will find the matching numbers that appear in both Sheet 1 and Sheet 2, and output them to Sheet 3. My code is below, but is producing no result. What am I doing wrong?
Sub match()
Dim a As Integer
dim i as long, ii as long
a = 2
Dim lastrow As Long
Dim ylastrow As Long
ylastow = Sheets("Sheet2").UsedRange.Rows.Count
lastrow = Sheets("Sheet1").UsedRange.Rows.Count
for i = a to lastrow
for ii = a to ylastrow
if Sheets("Sheet1").Cells(i,1) = Sheets("Sheet2").Cells(ii,2) then
Sheets("Sheet3").range("A100000").xlup
End Sub
Assuming you want the matching cells copied into sheet3 by rows continuously
You are missing next ii and next i and end if also your destination cell in sheet3 is not set right
this should work
Sub match()
Dim a As Integer
Dim i As Long, ii As Long, j As Long
a = 2
j = 2
Dim lastrow As Long
Dim ylastrow As Long
Sheet1rows = Sheets("Sheet1").UsedRange.Rows.Count + 1
sheet2rows = Sheets("Sheet2").UsedRange.Rows.Count + 1
For i = a To Sheet1rows
For ii = a To sheet2rows
If Sheets("Sheet1").Cells(i, 1) = Sheets("Sheet2").Cells(ii, 1) Then
Sheets("Sheet3").Range("A" & j) = Sheets("Sheet1").Cells(i, 1)
j = j + 1
End If
Next ii
Next i
End Sub