Найдите совпадение, скопируйте всю строку и вставьте в соответствующий

Question

Столбец B на «Sheet2» содержит 370 строк данных. Начиная с ячейки B1 «Sheet2», я хочу найти соответствующее значение в столбце B на «Sheet1» (оно может быть расположено в любом месте первых 300 строк столбца B «Sheet1»). Если совпадение найдено, скопируйте всю строку из «Sheet1» и вставьте в Row1 на «Sheet2». Затем перейдите к ячейке B2 «Лист2» ​​и повторите поиск, на этот раз вставив всю строку из «Лист1» в строку2 на «Лист2». Продолжайте перемещаться по всему столбцу данных на «Sheet2», ища значение каждой ячейки на «Sheet1». Если поиск не возвращает совпадения, не вставляйте ничего в эту строку на «Sheet2» и просто переходите к поиску следующей ячейки на «Sheet2». (Например, если Sheet1 Col B не содержит совпадения с Sheet2 Cell B3, тогда ничего не будет вставлено в Sheet2 Row3.)

Я нашел следующий пример, который начинает мне помогать, но в нем указывается значение поиска и не l oop через весь столбец значений, как я пытаюсь сделать.

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. Как только ваш l oop будет готово, скопируйте весь диапазон сразу если 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