对于列中的每个值循环遍历表并复制每个实例的行，粘贴到另一个工作表

Question

对于 Sheet("Scrap2") A 列中的每个值。

在 Sheet("VA_Data") 的 A 列中找到该值的所有匹配实例。复制整行并粘贴到工作表上的第一个空行（“列表”）

我的代码现在基本上只复制匹配的第一个实例，然后移动到 Sheet("Scrap2") 中的下一个值。

如果工作表“VA_Data”的 col A 中有 10 个单元格与 Scrap2 的第一个值匹配，则这 10 行需要复制整行并粘贴到工作表“List”上的第一个空行。

感谢任何帮助。

Option Explicit

Public Sub Loop_VA_Data()
    
Dim wsa As Worksheet
Dim wsb As Worksheet
Dim wsc As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim stra As String
Dim rng As Range

On Error GoTo errLoop_VA_Data

    Application.ScreenUpdating = False

    Set wsa = ThisWorkbook.Worksheets("Scrap2")
    Set wsb = ThisWorkbook.Worksheets("VA_Data")
    Set wsc = ThisWorkbook.Worksheets("List")
    
    wsa.Range("B:B").Clear
    wsc.Rows("2:" & wsc.Range("A1").CurrentRegion.Rows.Count + 1).Clear
    a = 2
    
    Do
    
        If Trim(wsa.Cells(a, 1).Value) = "" Then
            Exit Do
        End If
        
        stra = Trim(wsa.Cells(a, 1).Value)
        
        Set rng = wsb.Range("A:A").Find(What:=stra, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not (rng Is Nothing) Then
            b = rng.Row
            c = wsc.Range("A1").CurrentRegion.Rows.Count + 1
            wsb.Rows(b).Copy wsc.Rows(c)
            wsa.Cells(a, 2).Value = "Found on row " & b
        Else
            wsa.Cells(a, 2).Value = "Not Found"
        End If
        
        If Not (rng Is Nothing) Then
            Set rng = Nothing
        End If
        
        a = a + 1
    
    Loop
    
    MsgBox "Complete!", vbInformation
    
    GoTo closeout
    
    Exit Sub
    
errLoop_VA_Data:
    MsgBox "Err Number is: " & Err.Number & " / Err Desc is: " & Err.Description & " in sub Loop_VA_Data!", vbCritical
    
closeout:
    If Not (wsa Is Nothing) Then
        Set wsa = Nothing
    End If
    
    If Not (wsb Is Nothing) Then
        Set wsb = Nothing
    End If
    
    If Not (wsc Is Nothing) Then
        Set wsc = Nothing
    End If
    
    If Not (rng Is Nothing) Then
        Set rng = Nothing
    End If
    
    Exit Sub
    
End Sub

Answer 1

我认为@urdearboy 的想法是正确的 - 使用过滤器和大量复制。以下代码假定您的 VA_Data 工作表上的数据是连续的。让我知道你是怎么做的。

Option Explicit
Sub Filter_Copy()
Application.ScreenUpdating = False
    
Dim c As Range
Dim LastRow As Long, PasteRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet

Set ws1 = Sheets("Scrap2")
Set ws2 = Sheets("VA_Data")
Set ws3 = Sheets("List")
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row

For Each c In ws1.Range(ws1.Cells(1, 1), ws1.Cells(LastRow, 1))
    With ws2.Cells(1, 1).CurrentRegion
        .AutoFilter 1, c.Value
        PasteRow = ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Offset(1).Resize(.Rows.Count - 1).Copy ws3.Range("A" & PasteRow)
        .AutoFilter
    End With
Next c

End Sub