Try this:-
Data on sheet "Data", results on sheet "Results".
Sub MG07Jan45
Dim temp As String
Dim Dic As Object
Dim Ray As Variant
Dim txt As String
Dim n As Long
Dim k As Variant
Dim p As Variant
Dim c As Long
Dim Sp As Variant
Ray = Sheets("Data").Cells(1).CurrentRegion.Resize(, 6)
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
For n = 2 To UBound(Ray, 1)
txt = Ray(n, 1) & "," & Ray(n, 2) & "," & Ray(n, 3)
If Not Dic.exists(txt) Then
Set Dic(txt) = CreateObject("Scripting.Dictionary")
End If
If Not Dic(txt).exists(Ray(n, 4)) Then
Dic(txt).Add (Ray(n, 4)), Ray(n, 6)
Else
Dic(txt).Item(Ray(n, 4)) = Dic(txt).Item(Ray(n, 4)) + Ray(n, 6)
End If
Next n
c = 1
With Sheets("Results")
.Range("A1").Resize(, 6) = Array("Product Code", "Product Name", "Territory Name", "Outlet Name", "Area Tot", "Rank")
For Each k In Dic.Keys
temp = c
For Each p In Dic(k)
c = c + 1
Sp = Split(k, ",")
.Cells(c, "A") = Sp(0)
.Cells(c, "B") = Sp(1)
.Cells(c, "C") = Sp(2) ':
.Cells(c, "D") = p
.Cells(c, "E") = Dic(k).Item(p)
Next p
For n = temp + 1 To c
.Cells(n, "F") = Application.Rank(.Cells(n, "E"), .Cells(temp + 1, "E").Resize(c - temp), 0)
Next n
Next k
With .Range("A1").Resize(c, 6)
.Borders.Weight = 2
.Columns.AutoFit
End With
End With
End Sub
Regards Mick
Bookmarks