Sub ertert()
Dim x, y(), i&, k&, n&
Dim cl&, rw&, wsh As Worksheet

With Sheets("Лист1")
    x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
k = 1: n = 1
Set wsh = Sheets("Лист2")
wsh.UsedRange.ClearContents

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(x)
        If .exists(x(i, 1)) Then
            rw = .Item(x(i, 1))
        Else
            k = k + 1: .Item(x(i, 1)) = k: rw = k
            wsh.Cells(k, 1) = x(i, 1)
        End If

        If .exists(x(i, 2)) Then
            cl = .Item(x(i, 2))
        Else
            n = n + 1: .Item(x(i, 2)) = n: cl = n
            wsh.Cells(1, n) = x(i, 2)
        End If
        wsh.Cells(rw, cl) = x(i, 2)
    Next i
End With
wsh.Activate
End Sub