Dim objDic As Object
Dim c As Range
Dim vntKeys As Variant
Dim vntItems As Variant
Set objDic = CreateObject("Scripting.Dictionary")
For Each c In Range("B1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not objDic.exists(c.Value) Then
objDic.Add c.Value, c.Offset(, 1).Value
Else
objDic(c.Value) = objDic(c.Value) & "," & c.Offset(, 1).Value
End If
Next
vntKeys = objDic.keys
vntItems = objDic.items
Range("B1:C" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
Cells(1, 2).Resize(UBound(vntKeys) + 1) = WorksheetFunction.Transpose(vntKeys)
Cells(1, 3).Resize(UBound(vntItems) + 1) = WorksheetFunction.Transpose(vntItems)
End Sub