Sub test()
Dim Arr, Brr, D As Object, i&, t, tmp
Set D = CreateObject("scripting.dictionary")
Arr = [a1].CurrentRegion
a = 0
For i = 2 To UBound(Arr)
a = WorksheetFunction.Max(a, WorksheetFunction.CountIf(Columns(3), Arr(i, 3)))
If D.exists(Arr(i, 3)) Then
D(Arr(i, 3)) = D(Arr(i, 3)) & "," & Arr(i, 2)
Else
D(Arr(i, 3)) = Arr(i, 2)
End If
Next
ReDim Brr(1 To D.Count, 1 To a + 1)
i = 0
For Each t In D.keys
i = i + 1
Brr(i, 1) = t
tmp = Split(D(t), ",")
For j = 0 To UBound(tmp)
Brr(i, j + 2) = tmp(j)
Next
Next
[i5].Resize(UsedRange.Rows.Count, 7).Clear
[i5].Resize(D.Count, 7).Borders.LineStyle = xlContinuous
[i5].Resize(D.Count).FormulaR1C1 = "=ROW(R[-4]C[-8])"
[j5].Resize(D.Count, 6) = Brr
End Sub
