Сравнения столбцов с последующим копированием

[Hugo121]

Без проверки, пробуйте:

Option Explicit

Sub ttt()
    Dim r As Range, a(), i&, ii&, x&

    On Error Resume Next
    With CreateObject("Scripting.Dictionary")

        Set r = Application.InputBox(Prompt:="Выделите первый диапазон для сравнения (1 столбец)", Type:=8)
        If r Is Nothing Then Exit Sub
        a = r.Value
        For i = 1 To UBound(a): .Item(a(i, 1)) = 0&: Next

        Set r = Application.InputBox(Prompt:="Выделите второй диапазон для сравнения (диапазон смежных столбцов!)", Type:=8)
        If r Is Nothing Then Exit Sub
        a = r.Value
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then
                ii = ii + 1
                For x = 1 To UBound(a, 2): a(ii, x) = a(i, x): Next
            End If
        Next

    End With

    If ii > 0 Then Workbooks.Add(1).Sheets(1).[a1].Resize(ii, UBound(a, 2)) = a

End Sub

[zontique]

Работает. Спасибо вам большое.