How to copy rows from one worksheet to a new worksheet if a cell matches a cell from anothe worksheet

[DennisYoung]

What I am trying to accomplish is, I have 3 worksheets, sheet 1 and sheet 2, and sheet3, Column B of worksheet 1 is account number, column B of worksheet 2 is also account number, worksheet 3 is currently blank. I want to compare column B of WS 2 with column B of WS1 and if WS2 matches the account number in WS1 then copy that entire row from WS2 to WS3 first available row and so forth.

 

[kevin9999]

Try the following on a copy of your workbook - just change the sheet names in the code to suit.

Option Explicit
Sub DennisYoung()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Sheet1")  '<~~ *** Change sheet names to actual sheet names ***
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
    
    Dim a, i As Long
    a = ws1.Range("B2:B" & ws1.Cells(Rows.Count, "B").End(xlUp).Row).Value
    a = Application.Transpose(Application.Index(a, 0, 1))
    For i = LBound(a) To UBound(a)
        a(i) = CStr(a(i))
    Next i
    
    With ws2.Range("A1").CurrentRegion
        .AutoFilter 2, Array(a), 7
        If ws2.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Range("A" & ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        End If
        ws2.ShowAllData
    End With
End Sub

 

[DennisYoung]

Try the following on a copy of your workbook - just change the sheet names in the code to suit.

Option Explicit
Sub DennisYoung()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Sheet1")  '<~~ *** Change sheet names to actual sheet names ***
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
   
    Dim a, i As Long
    a = ws1.Range("B2:B" & ws1.Cells(Rows.Count, "B").End(xlUp).Row).Value
    a = Application.Transpose(Application.Index(a, 0, 1))
    For i = LBound(a) To UBound(a)
        a(i) = CStr(a(i))
    Next i
   
    With ws2.Range("A1").CurrentRegion
        .AutoFilter 2, Array(a), 7
        If ws2.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Range("A" & ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1)
        End If
        ws2.ShowAllData
    End With
End Sub

Thank you very much! Worked like a charm.

 

[kevin9999]

Thank you very much! Worked like a charm.

Happy to help, and thanks for the feedback