how to copy multiple row to another sheet in specific cell based on value excel VBA

Question

excuse me i want to ask how to copy multiple row to another sheet in specific cell based on value

so i got 2 sheet first sheet is "RawData"

RawData

  A      B       C       D

1 test1  test2   test3   test4
2 A-001  SP-001  Anne    America
3 A-002  SP-001  Chris   America
4 A-003  SP-002  Kenth   Dutch
5 A-004  SP-001  Keith   Dutch
6 A-005  SP-003  Lia     America

and i want to copy a row that contain a value in Second Sheet "Report" Cell "A1" for example in Sheet "Report" range A1 contain value SP-001 and the Row that contain SP-001 copy to B4 in Sheet "Report"

Report

    A        B       C        D        E       F
1   SP-001
2
3            test1   test2    test3    test4
4            A-001   SP-001   Anne     America
5            A-002   SP-001   Chris    America
6            A-004   SP-001   Keith    Dutch

i trying with vba using this

Sub tgr()

    Dim rngFound As Range
    Dim strFirst As String
    Dim strID As String
    Dim i As Long

    i = 3

    strID = Worksheets("test1").Range("A1").Value


    Set rngFound = Columns("B").Find(strID, Cells(Rows.Count, "B"), xlValues, xlWhole)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Do
            If LCase(Cells(rngFound.Row, "B").Text) = LCase(strID) Then

                'Found a match
                'MsgBox rngFound.Row
                 Worksheets("test").Range("A" & rngFound.Row & ":" & "D" & rngFound.Row).Copy Worksheets("test1").Range("E" & i + 1)

            End If
            Set rngFound = Columns("B").Find(strID, rngFound, xlValues, xlWhole)
        Loop While rngFound.Address <> strFirst
    End If

    Set rngFound = Nothing

End Sub

but it always copy the last row contain SP-001 and not loop at all, even though i already check the row with msgbox and its looping

Thank You In Advance

Answer 1

you can use AutoFilter():

Private Sub main()
    Dim repSht As Worksheet
    Set repSht = Worksheets("Report")

    With Worksheets("RawData")
        With .Range("D1", .Cells(.Rows.Count, "A").End(xlUp))
            .AutoFilter field:=2, Criteria1:=repSht.Range("A1").Value2
            With Intersect(ActiveSheet.UsedRange, .EntireColumn).Resize(.Rows.Count - 1).Offset(1, 0)
                If CBool(Application.Subtotal(103, .Cells)) Then .SpecialCells(xlCellTypeVisible).Copy repSht.Range("b4")
            End With
        End With
    End With
End Sub