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

Question

"Sheet2" 上的列 B 包含 370 行数据。从 "Sheet2" 单元格 B1 开始，我想在 "Sheet1" 的列 B 中搜索匹配值（它可以位于 "Sheet1" 列 B 的前 300 行中的任何位置）。如果找到匹配项，请从 "Sheet1" 复制整行并粘贴到 "Sheet2" 上的第 1 行。然后，移动到 "Sheet2" 单元格 B2 并重复搜索，这次将整个行从 "Sheet1" 粘贴到 "Sheet2" 上的第 2 行。继续浏览 "Sheet2" 上的整列数据，搜索 "Sheet1" 上每个单元格的值。如果搜索 return 不匹配，则不要向 "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

使用Range.Find搜索匹配的单元格
使用 Union 创建找到的行的集合
循环完成后，立即复制所有范围如果 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

Answer 2

这应该可以解决问题，而且速度很快：

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

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

Search for a match, copy entire row, and paste to corresponding

excel

vba

copy-paste