Sub CompareTwoSheets()
Dim arr1(), arr2(), arr3(), I&, dic, N&
On Error Resume Next
With Worksheets("Лист №1")
    lRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    lClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr1 = .Range(.Cells(2, 1), .Cells(lRow, lClm)).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(arr1)
    dic.Add CStr(arr1(I, 2)), arr1(I, 1) & "^" & arr1(I, 3) & "^" & arr1(I, 4)
Next
With Worksheets("Лист №2")
    lRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    lClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr2 = .Range(.Cells(2, 1), .Cells(lRow, lClm)).Value
End With
For I = 1 To UBound(arr2)
    If dic.Exists(CStr(arr2(I, 2))) Then
        ReDim Preserve arr3(7, N)
        iStr = Split(dic(CStr(arr2(I, 2))), "^")
        arr3(0, N) = iStr(0)
        arr3(1, N) = Format(CStr(arr2(I, 2)), "000000000000")
        arr3(2, N) = iStr(1)
        arr3(3, N) = arr2(I, 1)
        arr3(4, N) = arr2(I, 3)
        arr3(5, N) = arr2(I, 4)
        arr3(6, N) = iStr(2)
        N = N + 1
    End If
Next
Worksheets("Лист №3").Range("A2").Resize(UBound(arr3, 2) + 1, 7) = Application.Transpose(arr3)
End Sub

Sub qq()
    Dim ar1, ar2, ar3
    With Worksheets("Лист №1").Cells(1, 1).CurrentRegion: ar1 = .Offset(1).Resize(.Rows.Count - 1).Value: End With
    With Worksheets("Лист №2").Cells(1, 1).CurrentRegion: ar2 = .Offset(1).Resize(.Rows.Count - 1).Value: End With
    With CreateObject("Scripting.Dictionary")
        If UBound(ar1) > UBound(ar2) Then
            ReDim ar3(1 To UBound(ar1), 1 To 7)
            For i = 1 To UBound(ar1)
                .Item(ar1(i, 2)) = i
            Next
            For i = 1 To UBound(ar2)
                If .exists(ar2(i, 2)) Then
                    k = k + 1
                    ar3(k, 1) = ar1(.Item(ar2(i, 2)), 1)
                    ar3(k, 2) = "'" & ar2(i, 2)
                    ar3(k, 3) = ar1(.Item(ar2(i, 2)), 3)
                    ar3(k, 4) = ar2(i, 3)
                    ar3(k, 5) = ar2(i, 1)
                    ar3(k, 6) = ar2(i, 4)
                    ar3(k, 7) = ar1(.Item(ar2(i, 2)), 4)
                End If
            Next
        Else
            ReDim ar3(1 To UBound(ar2), 1 To 7)
            For i = 1 To UBound(ar2)
                .Item(ar2(i, 2)) = i
            Next
            For i = 1 To UBound(ar1)
                If .exists(ar1(i, 2)) Then
                    k = k + 1
                    ar3(k, 5) = ar2(.Item(ar1(i, 2)), 1) '5
                    ar3(k, 2) = "'" & ar1(i, 2)
                    ar3(k, 4) = ar2(.Item(ar1(i, 2)), 3) '4
                    ar3(k, 3) = ar1(i, 3) '3
                    ar3(k, 1) = ar1(i, 1) '1
                    ar3(k, 7) = ar1(i, 4) '7
                    ar3(k, 6) = ar2(.Item(ar1(i, 2)), 4) '6
                End If
            Next
        End If
    End With
    Worksheets("Лист №3").Cells(2, 1).Resize(k, 7) = ar3
End Sub

Option Explicit
Sub test()
Dim dic As Object
Dim arr(), i&, j&, x&
Set dic = CreateObject("Scripting.Dictionary")
arr = Лист1.UsedRange.Value
For i = 1 To UBound(arr)
    dic.Item(CStr(arr(i, 2))) = 0
Next i
arr = Лист2.UsedRange.Value
For i = 1 To UBound(arr)
    If dic.Exists(CStr(arr(i, 2))) Then
        j = j + 1
        For x = 1 To UBound(arr, 2)
            arr(j, x) = arr(i, x)
        Next
    End If
Next i
With Лист3
    .Cells.ClearContents
    .Columns(2).NumberFormat = "@"
    .Range("a1").Resize(j, UBound(arr, 2)) = arr
    .Cells.EntireColumn.AutoFit
End With
End Sub