根据工作表（项目）中的值将工作表（数据）中的行复制到工作表（结果）（Excel 2016）

Question

我的编码技能为零，我希望有人可以修改此代码或为我制作一个完全不同的代码。

我使用此代码根据在 Sheet(Items) 中找到的值将行从 Sheet(Data) 复制到 Sheet(Result)

Sub TestCopy()
Dim LastRow As Long
Dim i As Long, j As Long

With Worksheets("Data")
LastRow = .Cells(.Rows.count, "C").End(xlUp).Row
End With

MsgBox (LastRow)
With Worksheets("Result")
j = .Cells(.Rows.count, "C").End(xlUp).Row + 1
End With

For i = 1 To LastRow
With Worksheets("Data")
If .Cells(i, 3).Value = ThisWorkbook.Sheets("Items").Range("A1") Then
.Rows(i).Copy Destination:=Worksheets("Result").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub

但这只会移动单元格“A1”中具有值的行。 我需要的是根据 A1,A2,A3.... 中的值移动行，直到有一个空单元格。

例子：

数据表如下所示：

Sub Locator Item    On-Hand LPN Serial
ABC AA010101    445-0744166 1   PLK123456   XX45684
ABC AA010102    445-0719738 2   PLK123457   XX45685
ABC AA010103    000-0000000 3   PLK123458   XX45686
ABC AA010104    445-0719738 4   PLK123459   XX45687
ABC AA010105    000-0000000 5   PLK123460   XX45688
ABC AA010106    445-0719738 6   PLK123461   XX45689
ABC AA010107    000-0000000 7   PLK123462   XX45690
ABC AA010108    445-0719738 8   PLK123463   XX45691
ABC AA010109    000-0000000 9   PLK123464   XX45692
DEF BB010101    445-0744166 10  PLK123465   XX45693
DEF BB010102    2181-K090-V001  11  PLK123466   XX45694
DEF BB010103    2181-K090-V001  12  PLK123467   XX45695
DEF BB010104    000-0000000 13  PLK123468   XX45696
DEF BB010105    445-0744166 14  PLK123469   XX45697
DEF BB010106    000-0000000 15  PLK123470   XX45698
DEF BB010107    445-0720880 16  PLK123471   XX45699
DEF BB010108    2181-K090-V001  17  PLK123472   XX45700
DEF BB010109    000-0000000 18  PLK123473   XX45701
GHI CC010101    000-0000000 19  PLK123474   XX45702
GHI CC010102    2181-K090-V001  20  PLK123475   XX45703
GHI CC010103    000-0000000 21  PLK123476   XX45704
GHI CC010104    000-0000000 22  PLK123477   XX45705
GHI CC010105    445-0744166 23  PLK123478   XX45706
GHI CC010106    445-0720880 24  PLK123479   XX45707
GHI CC010107    000-0000000 25  PLK123480   XX45708
GHI CC010108    2181-K090-V001  26  PLK123481   XX45709
GHI CC010109    000-0000000 27  PLK123482   XX45710
JKL DD010101    445-0744166 28  PLK123483   XX45711
JKL DD010102    000-0000000 29  PLK123484   XX45712
JKL DD010103    000-0000000 30  PLK123485   XX45713
JKL DD010104    445-0720880 31  PLK123486   XX45714
JKL DD010105    445-0744166 32  PLK123487   XX45715
JKL DD010106    000-0000000 33  PLK123488   XX45716
JKL DD010107    445-0720880 34  PLK123489   XX45717
JKL DD010108    445-0744166 35  PLK123490   XX45718
JKL DD010109    000-0000000 36  PLK123491   XX45719

项目表如下所示：

445-0719738
2181-K090-V001
445-0744166
445-0720880

Answer 1

AutoFilter method 可以帮助您选择要查找的行，并将它们一起传送到结果工作表中。

Sub TestCopy_jpd()
    Dim v As Long, vITMs() As Variant, rng As Range
    With Worksheets("Items")
        With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            For Each rng In .Cells
                ReDim Preserve vITMs(v)
                vITMs(v) = rng.Value2
                v = v + 1
            Next rng
        End With
    End With
    With Worksheets("Data")
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Cells(1, 1).CurrentRegion
            .AutoFilter field:=3, Criteria1:=vITMs, Operator:=xlFilterValues
            'step down one row off the header
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                'are there rows to copy?
                If CBool(Application.Subtotal(103, .Cells)) Then
                    'there are visiblke rows - copy and paste them
                    .Cells.Copy _
                        Destination:=Worksheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                End If
            End With
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
End Sub

首先检查项目工作表并构造项目数组。这用作Range.AutoFilter Method 中的标准。快速检查是否有要复制的可见单元格，如果有，则复制和粘贴操作完成。

附录：

要解决您最初的问题，您需要检查数据工作表中的 Item 是否与 Items 工作表中列出的任何 Items 匹配。

With Worksheets("Data")
    For i = 1 To LastRow
        If Not IsError(Application.Match(.Cells(i, 3).Value, ThisWorkbook.Sheets("Items").Columns(1), 0)) Then
            .Rows(i).Copy Destination:=Worksheets("Result").Range("A" & j)
            j = j + 1
        End If
    Next i
End With

逐行执行此操作会明显变慢，但我想提供实现您最初目标的正确方法。