Sub DoIt()
Dim arrAB() As Variant, arrTmp
Dim oDict As Object
arrAB = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
Set oDict = GetDict(arrAB)
arrTmp = oDict.Items()
Cells(1, 4).Resize(UBound(arrTmp) + 1, 1).Value = Application.Transpose(arrTmp)
End Sub
Private Function GetDict(myArr As Variant) As Object
Dim x As Long
Set GetDict = CreateObject("Scripting.Dictionary")
For x = LBound(myArr, 1) To UBound(myArr, 1)
On Error Resume Next
GetDict.Add myArr(x, 1), myArr(x, 2)
If Err.Number Then
GetDict.Item(myArr(x, 1)) = GetDict.Item(myArr(x, 1)) _
& "," & myArr(x, 2)
End If
On Error GoTo 0
Next x
End Function