Excel VBA: For loop - Write value of row number

[rbsam]

The way my code currently works is like this:


ws1 has multiple columns and rows of data. The first cell on every row in column A is the title. The titles are from a fixed selection (it's a drop down) which are determined by a list that is on ws2


ws2 has the list of titles, which is h3 until LastRow


ws3 I'm trying to set up a for loop so from A6 onwards it writes 1 row of data from ws1 of each title.


So if ws2 has 5 titles, then ws3 will write 5 lines of data, and the data comes from the EntireRow on ws1


Currently, my for loop will return the correct titles and the row numbers of the matched data (which I have verified using debug print)


What I can't seem to figure out is how to get it to write on ws3 a line for each match. In my last line I have

ws3.Range("A6:A15").EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value

but this seems to print the last match on every row between A6 to A15 (so the same value on every row)


I feel like it's something to do with the placement of the code, as it doesn't seem to loop correctly. It's looping until the last line and then only returning the last line.

Sub CardsCollection()


Set ws1 = Sheets("Database")
Set ws2 = Sheets("Insert")
Set ws3 = Sheets("Sheet1")


Dim myCell As Range
Dim LastRow As Long


LastRow = ws2.Cells(ws2.Rows.Count, "H").End(xlUp).Row
Debug.Print LastRow


Dim test_string As String
test_string = "H" & LastRow
Dim test_range As Range
Set test_range = ws2.Range(test_string)






variable_condition = Range("C3")


For Each myCell In ws2.Range("H3" & ":" & test_string)
    Debug.Print myCell
    row_num2 = Evaluate("MATCH(1,('" & ws1.Name & "'!A:A=""" & myCell & """)*('" & ws1.Name & "'!F:F=""" & variable_condition & """),0)")
    Debug.Print row_num2
    ws3.Range("A6:A15").EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value
Next


End Sub

Would appreciate any help! Thanks

 

[Fluff]

Maybe

ws3.Range("A"&Rows.count).end(xlup).offset(1).EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value

 

[JackDanIce]

Save your work, then try this macro instead:

    Dim arr()   As Variant
    Dim s       As String
    Dim x       As Long
    Dim r       As Range
    Dim dic     As Object: Set dic = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    
    With sheets("Database")
         x = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Cells(1, 1).Resize(x, 6).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        dic(arr(x, 1) & arr(x, 6)) = x
    Next x
    
    With sheets("Insert")
        s = .Cells(3, 3).Value
        arr = .Cells(3, 8).Resize(.Cells(.Rows.Count, 8).End(xlUp).Row - 2).Value
    End With
    
    Set r = sheets("Sheet1").Cells(6, 1).Resize(10)
    For x = LBound(arr, 1) To UBound(arr, 1)
        If dic.exists(arr(x, 1) & s) Then
            r.EntireRow.Value = sheets("Database").Cells(dic(arr(x, 1) & s), 1).EntireRow.Value
            Set r = r.Offset(10)
        End If
    Next x

    Application.ScreenUpdating = True
    
    Erase arr: Set dic = Nothing: Set r = Nothing
    
End Sub

 

[rbsam]

Maybe

ws3.Range("A"&Rows.count).end(xlup).offset(1).EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value

This worked! Thanks for your help! Currently it's writing the results from A2 onwards, but I'm still designing the rest of the sheet so could you advise me how I can shift it down (for example, if I want it to start from A4).

 

[Fluff]

If you want to start in A4, make sure that A3 has a value in it.

 

[rbsam]

If you want to start in A4, make sure that A3 has a value in it.

Is there any where to make it start at a set point rather than starting from the first empty row?

 

[Fluff]

Yup like

NxtRw = 4
For Each myCell In ws2.Range("H3" & ":" & test_string)
    Debug.Print myCell
    row_num2 = Evaluate("MATCH(1,('" & ws1.Name & "'!A:A=""" & myCell & """)*('" & ws1.Name & "'!F:F=""" & variable_condition & """),0)")
    Debug.Print row_num2
    ws3.Range("A" & NxtRw).EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value
    NxtRw = NxtRw + 1
Next

 

[rbsam]

Yup like

NxtRw = 4
For Each myCell In ws2.Range("H3" & ":" & test_string)
    Debug.Print myCell
    row_num2 = Evaluate("MATCH(1,('" & ws1.Name & "'!A:A=""" & myCell & """)*('" & ws1.Name & "'!F:F=""" & variable_condition & """),0)")
    Debug.Print row_num2
    ws3.Range("A" & NxtRw).EntireRow.Value = ws1.Range("A" & row_num2).EntireRow.Value
    NxtRw = NxtRw + 1
Next

Perfect! Thanks for your help!

 

[Fluff]

You're welcome & thanks for the feedback