Sub BobbyJo()
Dim arr(), arrNew(), I&, iKey
With ActiveSheet
arr = .Range("A2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
On Error Resume Next
With CreateObject("Scripting.Dictionary")
For I = 1 To UBound(arr)
.Add CStr(arr(I, 1)), arr(I, 2)
If Err <> 0 Then
.Item(CStr(arr(I, 1))) = .Item(CStr(arr(I, 1))) & vbCrLf & arr(I, 2)
Err.Clear
End If
Next
ReDim arrNew(0 To .Count, 0 To 1): I = 0
For Each iKey In .Keys
arrNew(I, 0) = iKey
arrNew(I, 1) = .Item(iKey)
I = I + 1
Next
End With
ActiveSheet.Range("G2").Resize(I, 2) = arrNew
End Sub
Sub dc()
Dim dic
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To Cells(Rows.Count, 1).End(xlUp).row
key = Cells(i, 1).Value
item = Cells(i, 2).Value
If dic.exists(key) Then
dic.item(key) = dic.item(key) & Chr(10) & item
Else
dic.Add key, item
End If
Next
Cells(2, 6).Resize(dic.Count) = Application.Transpose(dic.Keys)
Cells(2, 7).Resize(dic.Count) = Application.Transpose(dic.Items)
End Sub