基于表单（项目）（Excel 2016）中的值将表格（数据）中的行复制到表格（结果）

Question

我的编码技巧就像零，我想如果任何人都可以修改此代码或为其创建完全不同的代码我。

我使用此代码从表（数据）的行复制到基于值表（结果）在表中找到（产品）

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中的标准。快速检查是否有可见的单元格要复制，如果存在，复制和粘贴操作即完成操作。

附录：

为了解决您原来的问题，你需要检查项目在工作表中的数据匹配任何项目在项目表中所列的。

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 

做这一行将会明显较慢，但我想提供一个实现您的原始目标的正确方法。