Try this:-
Sub MG18Jan32
Dim Rng As Range
Dim Dn As Range
Dim n As Long
Dim Dic As Object
Set Rng = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp))
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
If Not Dic.Exists(Dn.Value) Then
Dic.Add Dn.Value, Dn.Offset(, -1)
Else
Dic.Item(Dn.Value) = Dic.Item(Dn.Value) & "," & Dn.Offset(, -1)
End If
Next
For n = 1 To 5
Cells(2, 5 + n) = Dic.Item(Application.Large(Dic.keys, n))
Next n
End Sub
Regards Mick
Bookmarks