Как скопировать несколько строк на другой лист в определенной ячейке на основе значения Excel VBA

Question

извините, я хочу спросить, как скопировать несколько строк на другой лист в определенной ячейке на основе значения

так что я получил 2 листа, первый лист - "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

и я хочу скопировать строку, содержащую значение во втором листе «Отчет» Ячейка «A1», например, в листе «Отчет» диапазон А1 содержит значение SP-001 и строку, содержащую копию SP-001, в B4 в Лист "Отчет"

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

я пытаюсь с VBA, используя это

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

но он всегда копирует последнюю строку, содержащую SP-001, а не зацикливается вообще, хотя я уже проверял строку с помощью msgbox и ее зацикливания

Заранее спасибо

Answer 1

Sub tgr()
R = 1   'first row to paste data to
First = True

For Each Test In Worksheets("RawData").Range(Worksheets("RawData").Range("B2"), Worksheets("RawData").Range("B2").End(xlDown))
CountRepeat = WorksheetFunction.CountIf(Worksheets("Report").Columns("A:A"), Test.Value)

If CountRepeat = 0 Then
    test2 = Test.Value
    First = True
Else
    GoTo line1
End If


For Each cell In Worksheets("RawData").Range(Worksheets("RawData").Range("B2"), Worksheets("RawData").Range("B2").End(xlDown))
    If cell.Value = test2 Then
        If First = True Then
            First = False
            Worksheets("Report").Cells(R, 1).Value = test2
            Worksheets("Report").Cells(R + 2, 2).Value = "test1"
            Worksheets("Report").Cells(R + 2, 3).Value = "test2"
            Worksheets("Report").Cells(R + 2, 4).Value = "test3"
            Worksheets("Report").Cells(R + 2, 5).Value = "test4"
            Worksheets("Report").Cells(R + 3, 2).Value = cell.Offset(0, -1).Value
            Worksheets("Report").Cells(R + 3, 3).Value = cell.Value
            Worksheets("Report").Cells(R + 3, 4).Value = cell.Offset(0, 1).Value
            Worksheets("Report").Cells(R + 3, 5).Value = cell.Offset(0, 2).Value
            R = R + 4
        Else

            Worksheets("Report").Cells(R, 2).Value = cell.Offset(0, -1).Value
            Worksheets("Report").Cells(R, 3).Value = cell.Value
            Worksheets("Report").Cells(R, 4).Value = cell.Offset(0, 1).Value
            Worksheets("Report").Cells(R, 5).Value = cell.Offset(0, 2).Value
            R = R + 1
        End If
    End If
Next

line1:

Next

End Sub

Answer 2

вы можете использовать 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