搜索匹配，復制整行，粘貼到對應的

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