Vb macro coding for transpose - complete coding?

try

Sub test()
    Dim a, i As Long, n As Long, w
    With Cells(1).CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1: .Item(a(i, 1)) = VBA.Array(n, 2)
                    a(n, 1) = a(i, 1): a(n, 2) = a(i, 3): a(i, 3) = ""
                Else
                    w = .Item(a(i, 1)): w(1) = w(1) + 1
                    If UBound(a, 2) < w(1) Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                    End If
                    a(w(0), w(1)) = a(i, 3): a(i, 3) = ""
                    .Item(a(i, 1)) = w
                End If
            Next
        End With
        With .Offset(, .Columns.Count + 2).Resize(n, UBound(a, 2))
            .Value = a
            On Error Resume Next
            .SpecialCells(4).Value = "-"
            On Error GoTo 0
        End With
    End With
End Sub