搜索匹配，复制整行，并粘贴到对应的

Question

“Sheet2”上的 Col B 包含 370 行数据。 从“Sheet2”单元格 B1 开始，我想在“Sheet1”上的 Col B 中搜索匹配值（它可以位于“Sheet1”Col B 的前 300 行中的任何位置）。 如果找到匹配项，则从“Sheet1”复制整行并粘贴到“Sheet2”上的 Row1。然后，移动到“Sheet2”单元格 B2 并重复搜索，这次将整个行从“Sheet1”粘贴到“Sheet2”上的 Row2。继续遍历“Sheet2”上的整个数据列，在“Sheet1”上搜索每个单元格的值。如果搜索未返回匹配项，则不要将任何内容粘贴到“Sheet2”上的该行，然后继续搜索“Sheet2”上的下一个单元格。 （例如，如果 Sheet1 Col B 不包含 Sheet2 Cell B3 的匹配项，则 Sheet2 Row3 中不会粘贴任何内容。）

我找到了以下示例，它开始对我有所帮助，但它指定了搜索值，并且不会像我试图做的那样循环遍历整个值列。

Sub CopyYes()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    J = 1     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("E1:E1000")   ' Do 1000 rows
        If c = "yes" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub

Answer 1

这应该可以解决问题，而且要快：

Option Explicit
Sub CopyYes()

    'You need Microsoft Scripting Runtime library under Tools-References for this
    Dim arrPaste As Variant: arrPaste = Sheet2.UsedRange.Value
    Dim arrCopy As Variant: arrCopy = Sheet1.UsedRange.Value
    Dim MyMatches As New Dictionary: Set MyMatches = CreateDictionary(arrCopy)
    Dim i As Long
    For i = 1 To UBound(arrPaste)
        If arrPaste(i, 2) = vbNullString Then Exit For
        If MyMatches.Exists(arrPaste(i, 2)) Then PasteData arrPaste, arrCopy, i, MyMatches(arrPaste(i, 2))
    Next i
    Sheet2.UsedRange.Value = arrPaste
    Erase arrCopy
    Erase arrPaste

End Sub
Private Function CreateDictionary(arr As Variant) As Dictionary

    Dim i As Long
    Set CreateDictionary = New Dictionary
    For i = 1 To 300
        CreateDictionary.Add arr(i, 2), i
    Next i

End Function
Private Sub PasteData(arrPaste As Variant, arrCopy As Variant, i As Long, MyMatch As Long)

    Dim j As Long
    For j = 1 To UBound(arrCopy, 2)
        If arrCopy(MyMatch, j) = vbNullString Then Exit For
        arrPaste(i, j) = arrCopy(MyMatch, j)
    Next j

End Sub

Answer 2

1. 使用Range.Find 搜索匹配的单元格
2. 使用Union 创建找到的行的集合
3. 循环完成后，一次复制所有范围如果Union 不为空

---

Sub Shelter_In_Place()

Dim Source As Worksheet: Set Source = ThisWorkbook.Sheets("Sheet1")
Dim Target As Worksheet: Set Target = ThisWorkbook.Sheets("Sheet2")

Dim Found As Range, lr As Long
Dim CopyMe As Range

lr = Target.Range("B" & Target.Rows.Count).End(xlUp).Row

For i = 1 To lr
    Set Found = Source.Range("B:B").Find(Target.Range("B" & i), LookIn:=xlWhole)

    If Not Found Is Nothing Then
        If Not CopyMe Is Nothing Then
            Set CopyMe = Union(CopyMe, Target.Range("B" & i))
        Else
            Set CopyMe = Target.Range("B" & i)
        End If
    End If

    Set Fouund = Nothing
Next i

If Not CopyMe Is Nothing Then
    CopyMe.EntireRow.Copy
    Source.Range("A1").PasteSpecial xlPasteValues
End If

End Sub