Option Explicit
Sub compare()
    Dim a, b, c, iLastrow As Long, iLastcol As Long, i As Long, ii As Long, j As Long

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

    With Sheet2    'используется кодовое имя
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        iLastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
        b = .[a2].Resize(iLastrow - 1, iLastcol).Value
    End With

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

    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
                For j = 2 To UBound(b, 2)
                    c(i, j - 1) = b(.Item(a(i, 1)), j)
                Next j
            End If
        Next
    End With

    '5. выгрузка всего массива
    With Sheet1    'используется кодовое имя
        .[B3].Resize(UBound(c), UBound(b, 2) - 1) = c
        .Activate
    End With

End Sub