基于Sheet（Items）（Excel 2016）中的值将行（Sheet）（数据）中的行复制到Sheet（Result）
我的编码技能就像零，我想如果有人可以修改这个代码或为我做一个完全不同的代码。
我使用此代码根据Sheet（Items）中find的值将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”中find的值。 我需要的是根据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
AutoFilter方法可以帮助您select要查找的行，并将其一次传送到结果工作表。
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
首先检查项目工作表，并构build项目的数组。 这被用作Range.AutoFilter方法中的标准。 快速检查是否有可见的单元格复制，如果存在，复制和粘贴操作即完成操作。
附录：
要解决您的原始问题，您需要检查数据工作表中的项目是否与项目工作表中列出的任何项目匹配。
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
这样做逐行将明显慢，但我想提供实现您的原始目标的正确方法。