搜索匹配，复制整行，然后粘贴到相应的位置。

Question

从 "Sheet2 "单元格B1开始，我想在 "Sheet1 "单元格B中搜索匹配的值（它可能位于 "Sheet1 "单元格B的前300行中的任何位置），如果找到匹配的值，将整行从 "Sheet1 "复制并粘贴到 "Sheet2 "的Row1中。 然后，移动到 "Sheet2 "单元格B2并重复搜索，这次将整行从 "Sheet1 "粘贴到 "Sheet2 "的Row2。 继续在 "Sheet2 "上移动整个数据列，搜索 "Sheet1 "上每个单元格的值。 如果搜索结果不匹配，则不要粘贴任何东西到 "Sheet2 "上的那一行，只需继续搜索 "Sheet2 "上的下一个单元格。(例如，如果Sheet1 Col B不包含Sheet2单元格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