Return top ten sums based on another column with duplicates into new worksheet

[aread]

I am struggling with the code to return the top 10 of several different columns based on their total spend. For example, column N contains the transaction spend, column S is the supplier, and column AC is the supplier category. I need to be able to pull the top ten of each column based on column N into another worksheet sorted by highest spend. I know I could do this with pivot tables, but I have to do this every month, quarterly, and annually, so I want to be able to automate it. I also need to be able to keep the original data in the original worksheet.

Hopefully that all made sense. I have found and tried several different versions of code that I found online and tweaked to my situation, but am not able to get to anything that works for my requirements. I am trying to relearn after about 15 years of not using code so am very much a beginner.

Thank you!
Adrienne

 

[VBE313]

Hi Adrienne,

Your task seems pretty logical and easy to figure out, but it is harder without seeing data. Can you please give us some example data?

 

[aread]

Of course. Here is a screenshot

 

[VBE313]

 

[aread]

I want it to sum all the Amazon.com, all the supplier x, supplier y, etc, then determine rank, which is why I was trying to use code to automate it.

 

[aread]

Clarification to my above post... I am wanting to sum all of the spend for each supplier, then pull the top ten. I also need to do the same type of top 10 for the categories. I hope you can help!

 

[aread]

Update: I managed to put the below together to start, but all it does is put a zero in cells B1 and E1. I haven't figured out why it isn't working and haven't figured out how to have it only return the top ten Suppliers/Categories after summing the values from column N.

Option Explicit
Sub CreateUniqueSupp()
Dim ws As String
Dim Cl As Range
Dim Cnt As Long
ws = ActiveSheet.Name
With CreateObject("scripting.dictionary")
        For Each Cl In Range("U2", Range("U" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Cl.Offset(, -7).Value
            Else
                .Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, -7).Value
            End If
        Next Cl
        Sheets("Top10").Range("A1").Resize(.Count).Value = Application.Transpose(.Keys)
        Sheets("Top10").Range("B1").Resize(.Count).Value = Application.Transpose(.items)
        End With
With CreateObject("scripting.dictionary")
        For Each Cl In Range("AC2", Range("AC" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Cl.Offset(, -15).Value
            Else
                .Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, -15).Value
            End If
        Next Cl
        Sheets("Top10").Range("D1").Resize(.Count).Value = Application.Transpose(.Keys)
        Sheets("Top10").Range("E1").Resize(.Count).Value = Application.Transpose(.items)
        End With
End Sub

 

[aread]

Still need help please.

 

[aread]

Within the below code, I am trying to loop through the dictionary to extract only the top 10 values, but am getting a run-time error 424 Object Required at the "For Each v In .Keys"
Without that section, the code works without issue, but it is not filtered.

Sub ReturnTopTen()
Dim ws As String
Dim Cl As Range
Dim Cnt As Long
ws = ActiveSheet.Name
Dim v As Range
Dim dict As Object, Key, Val
Set dict = CreateObject("scripting.dictionary")

Sheets("DataAnalysis").Activate
With dict
        Dim listrng, criterrng As Range
        For Each Cl In Range("U2", Range("U" & Rows.Count).End(xlUp))
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Cl.Offset(, -7).Value
            Else
                .Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, -7).Value
            End If
        Next Cl
        
        For Each v In .Keys
        Set listrng = v
        Set criterrng = dict.Item(v)
        listrng.AdvancedFilter Action:=xlTop10Items, CriteriaRange:=criterrng
        Next v
        
        Sheets("Top10").Range("A1").Resize(.Count).Value = Application.Transpose(.Keys)
        Sheets("Top10").Range("B1").Resize(.Count).Value = Application.Transpose(.Items)
        
        Set dict = Nothing
        Set v = Nothing
        
End With

 

[aread]

Bumping. Please help ?