Give this a try
Sub abc()
Dim arr, itm
Dim i As Long
arr = Range("a1").CurrentRegion.Value
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If Not .exists(arr(i, 1)) Then
itm = Join(Array(arr(i, 1), arr(i, 2), arr(i, 3)), "|")
Else
itm = Join(Array(.Item(arr(i, 1)), arr(i, 2), arr(i, 3)), "|")
End If
.Item(arr(i, 1)) = itm
Next
Cells.ClearContents: i = 1
For Each itm In .Keys
arr = Split(.Item(itm), "|")
Cells(i, 1).Resize(, UBound(arr) + 1) = arr
i = i + 1
Next
End With
End Sub
Bookmarks