Public Sub GPE()
Dim Dic As Object, Tmp
Dim I As Long, J As Long, K As Long, Arr, dArr
Arr = Range("E7", [E65000].End(3)).Resize(, 5)
ReDim dArr(1 To UBound(Arr, 1), 1 To 2)
Set Dic = CreateObject("Scripting.Dictionary")
With Dic
For J = 2 To UBound(Arr, 2)
For I = 1 To UBound(Arr)
If Arr(I, J) <> Empty Then
Tmp = Arr(I, J)
If Not .Exists(Tmp) Then
K = K + 1
.Add Tmp, K
dArr(K, 1) = Arr(I, J)
dArr(K, 2) = Arr(I, 1)
Else
dArr(.Item(Tmp), 2) = dArr(.Item(Tmp), 2) + Arr(I, 1)
End If
End If
Next I
Next J
End With
Range("K7:L65000").ClearContents
Range("K7").Resize(K, 2) = dArr
Range("K7").Resize(K, 2).Sort Range("K7")
End Sub
