如何根据值 excel VBA 将多行复制到特定单元格中的另一个 sheet

Question

对不起，我想问一下如何根据值

将多行复制到特定单元格中的另一个sheet

所以我得到了 2 sheet 第一个 sheet 是 "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

我想复制包含第二个 Sheet "Report" 单元格 "A1" 中的值的行，例如 Sheet "Report" 范围 A1 包含值 SP-001 和包含 SP-001 的行复制到 Sheet "Report"

中的 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

您可以使用 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

Answer 2

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

如何根据值 excel VBA 将多行复制到特定单元格中的另一个 sheet

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

excel

vba

copy-paste