try
Option Explicit

Sub test()
    Dim ws As Worksheet, a, i As Long, maxCol As Long, w
    For Each ws In Worksheets
        With ws.Range("a1").CurrentRegion
            a = .Resize(, 2).Value
            ReDim Preserve a(1 To UBound(a, 1), 1 To 100)
            With CreateObject("Scripting.Dictionary")
                .CompareMode = 1
                For i = 3 To UBound(a, 1)
                    If Not .exists(a(i, 1)) Then
                        .Item(a(i, 1)) = VBA.Array(i, 2)
                    Else
                        w = .Item(a(i, 1))
                        w(1) = w(1) + 1
                        If w(1) > UBound(a, 2) Then
                            ReDim Preserve _
                            a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
                        End If
                        a(w(0), w(1)) = a(i, 2)
                        a(i, 2) = Empty
                        .Item(a(i, 1)) = w
                        maxCol = Application.Max(maxCol, w(1))
                    End If
                Next
            End With
            .Resize(, maxCol).Value = a
        End With
    Next
End Sub