Try this:-
Results start "F1".
Sub MG30Apr17
Dim Rng As Range
Dn As Range
Dim n As Long
Dim Q
Set Rng = Range(Range("A2"), 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)
Range("F" & n).Resize(, 4) = Dn.Resize(, 4).Value
Else
Q = .Item(Dn.Value)
Q(1) = Q(1) + 3
Range("F" & Q(0)).Offset(, Q(1)).Resize(, 3) = Dn.Offset(, 1).Resize(, 3).Value
.Item(Dn.Value) = Q
End If
Next
End With
End Sub
Regards Mick
Bookmarks