This must do the trick for you.
It is not my own code, but I've adapted to your wishes.
Sub tst()
Dim Rng As Range
Dim Dn As Range
Dim n As Long
Dim Q
With Sheets(1)
Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
n = n + 1
.Add Dn.Value, Array(n, 1)
Sheets(2).Range("A" & n).Resize(, 3) = Dn.Resize(, 3).Value
Else
Q = .Item(Dn.Value)
Q(1) = Q(1) + 2
With Sheets(2)
.Range("A" & Q(0)).Offset(, Q(1)).Resize(, 2) = Dn.Offset(, 1).Resize(, 2).Value
.Range("A1").Offset(, Q(1)).Resize(, 2) = Sheets(1).Range("B1").Resize(, 2).Value
End With
.Item(Dn.Value) = Q
End If
Next
End With
End With
End Sub
Bookmarks