Sub rrwr()
Dim a, b, c, i, iLastrow As Long
Dim d As String
    iLastrow = Cells(Rows.Count, 3).End(xlUp).Row
    
    For i = 1 To iLastrow
        Cells(i + 1, 6) = Cells(i + 1, 1) & Cells(i + 1, 2) & Cells(i + 1, 3)
    Next
    


For i = 1 To iLastrow ' счетчик строк на листе 2
    If i = 2 Then
        i = 2
    End If
    For a = 1 To iLastrow 'счетчик строк на листе 1
        If Лист2.Cells(1 + i, 5) = Лист1.Cells(a + 1, 6) Then
            Лист1.Rows(a + 1).Copy
              d = Лист2.Cells(1 + i, 4).Value
                Sheets(d).Rows(a + 1).PasteSpecial
         
        
        Else
            Debug.Print "ne ok"
        End If
    
    Next
Next
    'For a = 1 To iLastrow
 
      '  If Лист2.Cells(i + 1, 5) = Лист1.Cells(i + 1, 6) Then
       '     Debug.Print "ok"
      '  Else
       '     Debug.Print "ne ok"
        'End If
  '  Next


End Sub

Option Explicit


Sub rrwr()
Dim a, b, c, d, i, iLastrow As Long
    iLastrow = Cells(Rows.Count, 3).End(xlUp).Row
    
    For i = 1 To iLastrow
        Cells(i + 1, 6) = Cells(i + 1, 1) & Cells(i + 1, 2) & Cells(i + 1, 3)
    Next
    
For i = 1 To iLastrow

    For a = 1 To iLastrow
    
        If Лист2.Cells(2, 5) = Лист1.Cells(a + 1, 6) Then
            Rows(a + 1).Copy
                Лист2.Cells(2, 4) = d
                d = Лист2.Cells(2, 4).Value
                Лист1(d).Rows(a + 1).Paste
        
        Else
            Debug.Print "ne ok"
        End If
    Next
Next
   

End Sub

Sub compare2223()
    Dim a, b, c, iLastrow As Long, i As Long, ii As Long

    '1. данные в два массива
    With Sheet3    'используется кодовое имя
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        a = Range(.[I2], .Range("I" & iLastrow)).Value
    End With

    With Лист1    'используется кодовое имя
        iLastrow = .Cells(Rows.Count, 9).End(xlUp).Row
        b = Range(.[I2], .Range("I" & iLastrow)).Value
    End With

    '2.пустой массив для результата
    ReDim c(1 To UBound(a), 1 To 9)

    With CreateObject("Scripting.Dictionary")
    
        '3.в словарь уникальные и номер строки из массива
        For i = 1 To UBound(b)
            .Item(b(i, 1)) = i
        Next

        '4.по словарю из массива b в массив c
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then
                c(i, 9) = b(.Item(a(i, 18)), 9)
            End If
        Next
    End With

    '5. выгрузка всего массива
    With Sheet3    'используется кодовое имя
        .[F2].Resize(UBound(c), 3) = c
        .Activate
    End With

End Sub

'Макросом -
'1.два диапазона в два массива
'2.создание массива для результатов
'3.один перебор 300 значений массива в словарь
'4.100 000 проверок массива на наличие в словаре и заполнение единицами массива результата
'5.выгрузка результатов
 
Sub compare()
    Dim a, b, c, d, e, iLastrow As Long, i As Long
    Dim tm: tm = Timer
    '1.
        With Лист2 'используется кодовое имя
                iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
                 b = Range(.[A2], .Range("d" & iLastrow)).Value
    
        End With
 
        With Лист1 'используется кодовое имя
                iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
                a = Range(.[A2], .Range("d" & iLastrow)).Value
 
        End With
 
'2.
            ReDim c(1 To UBound(a), 1 To 1)
 
'3.
         With CreateObject("Scripting.Dictionary")
                     For i = 1 To UBound(b) 
                    .Item(b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4)) = CStr(1)
                Next
 
'4.
                    For i = 1 To UBound(a)
                    If .exists(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)) Then c(i, 1) = 1
                Next
        End With
 
'5.
        With Лист1 'используется кодовое имя
            Range(.[F1], .Range("F" & iLastrow)).Value = c
        End With
 
MsgBox Timer - tm 'окно с таймером, годная тема
End Sub

Sub compare()
Dim a, b, c, d, e, iLastrow As Long, i As Long
Dim tm: tm = Timer
'1.
With Sheet2 
iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
b = Range(.[A1], .Range("A" & iLastrow)).Value
'd = Range(.[B1], .Range("B" & iLastrow)).Value

End With

With Sheet1
iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
a = Range(.[A1], .Range("A" & iLastrow)).Value
'e = Range(.[B1], .Range("B" & iLastrow)).Value

End With

'2.
ReDim c(1 To UBound(a), 1 To 1)

'3.
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(b)
            .Item(b(i, 1)) = CStr(1)
    Next

'4.
    For i = 1 To UBound(a)
      If .exists(a(i, 1)) Then c(i, 1) = 1
    Next
End With

'5.
With Sheet1 
Range(.[C1], .Range("C" & iLastrow)).Value = c
End With

MsgBox Timer - tm 
End Sub