Sub PlayWithArray()
Dim SArr, RArr, Dic1, MaxCols As Long
Dim i As Long, s As Long, EndR As Long, n As Long
t = Timer
Set Dic1 = CreateObject("Scripting.Dictionary")
With Dic1
EndR = Sheet2.[A65000].End(xlUp).Row
SArr = Sheet2.Range("A2:C" & EndR).Value
ReDim RArr(1 To EndR - 1, 1 To 12)
MaxCols = 2
For i = 1 To UBound(SArr, 1)
If Not .Exists(SArr(i, 1)) Then
s = s + 1
.Add SArr(i, 1), s
RArr(s, 1) = SArr(i, 1)
RArr(s, 2) = SArr(i, 2)
RArr(s, 11) = SArr(i, 3)
RArr(s, 12) = 2
Else
n = .Item(SArr(i, 1))
RArr(n, 12) = RArr(n, 12) + 1
RArr(n, RArr(n, 12)) = SArr(i, 2)
RArr(n, 11) = RArr(n, 11) + SArr(i, 3)
If MaxCols < RArr(n, 12) Then MaxCols = RArr(n, 12)
End If
Next
End With
With Sheet2
.[N2].Resize(s, 11) = RArr
.[N2].Offset(, MaxCols).Resize(, 10 - MaxCols).EntireColumn.Delete
.[M1] = Timer - t
End With
End Sub