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

A

aread

New Member
Joined
Dec 27, 2019
Messages
37
Office Version
  1. 365
Platform
  1. Windows
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
 
Sort by date Sort by votes
How about
VBA Code: 
Sub aread2()
   Dim Cl As Range
   Dim Dary(1 To 2) As Object
   Dim i As Long, j As Long, r As Long
   Dim Mx As Double
   Dim Ary As Variant
   
   For i = 1 To 2
      Set Dary(i) = CreateObject("scripting.dictionary")
   Next i
   With Sheets("DataAnalysis")
      For Each Cl In .Range("U2", .Range("U" & Rows.Count).End(xlUp))
         Dary(1)(Cl.Value) = Dary(1)(Cl.Value) + Cl.Offset(, -7).Value
         Dary(2)(Cl.Offset(, 8).Value) = Dary(2)(Cl.Offset(, 8).Value) + Cl.Offset(, -7).Value
      Next Cl
   End With
   With Sheets("Top 10")
      .Range("A1:B1").Value = Array("Supplier", "Amount")
      .Range("D1:E1").Value = Array("Catagory", "Amount")
      For j = 1 To 2
         r = 0
         Mx = Application.Large(Dary(j).Items, 10)
         ReDim Ary(1 To 10, 1 To 2)
         For i = 0 To Dary(j).Count - 1
            If Dary(j).Items()(i) >= Mx Then
               r = r + 1
               Ary(r, 1) = Dary(j).Keys()(i)
               Ary(r, 2) = Dary(j).Items()(i)
            End If
         Next i
         .Cells(2, IIf(j = 1, 1, 4)).Resize(10, 2).Value = Ary
      Next j
   End With
End Sub
 
Upvote 0

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
It was working great until I tried to add a third Dary/Array. I actually want it to concatenate the data in cells G & H first, but updated the code to the below only for G as a start. I obviously missed something because it is now putting #N/A in "Top10" columns C & F, rows 3-12. It is also adding a blank row for the Supplier/Supplier Spend and Category/Category Spend in row 11. I hope that made sense. I have been through it several times and can't seem to see what I did wrong.

VBA Code: 
Option Explicit
Sub ReturnTopTen()
    Dim Cl As Range
    Dim Dary(1 To 3) As Object
    Dim i As Long, j As Long, r As Long
    Dim Mx As Double
    Dim Ary As Variant

For i = 1 To 3
        Set Dary(i) = CreateObject("scripting.dictionary")
   Next i
   With Sheets("DataAnalysis")
      For Each Cl In .Range("U2", .Range("U" & Rows.Count).End(xlUp))
         Dary(1)(Cl.Value) = Dary(1)(Cl.Value) + Cl.Offset(, -7).Value
         Dary(2)(Cl.Offset(, 8).Value) = Dary(2)(Cl.Offset(, 8).Value) + Cl.Offset(, -7).Value
         Dary(3)(Cl.Offset(, -14).Value) = Dary(3)(Cl.Offset(, -14).Value) + Cl.Offset(, -7).Value
      Next Cl
   End With
   With Sheets("Top10")
      .Range("A1:B1").Value = Array("Supplier", "Supplier Spend")
      .Range("D1:E1").Value = Array("Category", "Category Spend")
      .Range("G1:H1").Value = Array("Card Holder", "User Spend")
      For j = 1 To 3
         r = 0
         Mx = Application.Large(Dary(j).Items, 10)
         ReDim Ary(1 To 10, 1 To 2)
         For i = 0 To Dary(j).Count - 1
            If Dary(j).Items()(i) >= Mx Then
               r = r + 1
               Ary(r, 1) = Dary(j).Keys()(i)
               Ary(r, 2) = Dary(j).Items()(i)
            End If
         Next i
         .Cells(3, IIf(j = 1, 1, 4)).Resize(10, 3).Value = Ary
      Next j
   End With

ActiveWorkbook.Worksheets("Top10").Range("A2:B11").Select
ActiveWorkbook.Worksheets("Top10").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Top10").Sort.SortFields.Add2 Key:=Range("B2:B11") _
    , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").Sort
        .SetRange Range("A1:B11")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("D1:E11").Select
    ActiveWorkbook.Worksheets("Top10").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top10").Sort.SortFields.Add2 Key:=Range("E2:E11") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").Sort
        .SetRange Range("D1:E11")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("G1:H11").Select
    ActiveWorkbook.Worksheets("Top10").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top10").Sort.SortFields.Add2 Key:=Range("H2:H11") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").Sort
        .SetRange Range("G1:H11")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


End Sub
 
Upvote 0
Try
VBA Code: 
         Next i
         .Cells(2, choose(j, 1, 4, 7)).Resize(10, 2).Value = Ary
      Next j
 
Upvote 0
This will also do the sorting
VBA Code: 
Sub ReturnTopTen()
    Dim Cl As Range
    Dim Dary(1 To 3) As Object
    Dim i As Long, j As Long, r As Long
    Dim Mx As Double
    Dim Ary As Variant

   For i = 1 To 3
        Set Dary(i) = CreateObject("scripting.dictionary")
   Next i
   With Sheets("DataAnalysis")
      For Each Cl In .Range("U2", .Range("U" & Rows.Count).End(xlUp))
         Dary(1)(Cl.Value) = Dary(1)(Cl.Value) + Cl.Offset(, -7).Value
         Dary(2)(Cl.Offset(, 8).Value) = Dary(2)(Cl.Offset(, 8).Value) + Cl.Offset(, -7).Value
         Dary(3)(Cl.Offset(, -14).Value) = Dary(3)(Cl.Offset(, -14).Value) + Cl.Offset(, -7).Value
      Next Cl
   End With
   With Sheets("Top10")
      .Range("A1:B1").Value = Array("Supplier", "Supplier Spend")
      .Range("D1:E1").Value = Array("Category", "Category Spend")
      .Range("G1:H1").Value = Array("Card Holder", "User Spend")
      For j = 1 To 3
         r = 0
         Mx = Application.Large(Dary(j).Items, 10)
         ReDim Ary(1 To 10, 1 To 2)
         For i = 0 To Dary(j).Count - 1
            If Dary(j).Items()(i) >= Mx Then
               r = r + 1
               Ary(r, 1) = Dary(j).Keys()(i)
               Ary(r, 2) = Dary(j).Items()(i)
            End If
         Next i
         With .Cells(2, choose(j, 1, 4, 7))
            .Resize(10, 2).Value = Ary
            .Offset(-1).Resize(11, 2).Sort Key1:=.Offset(-1, 1), Order1:=xlDescending, Header:=xlYes
         End With
      Next j
   End With
End Sub
 
Upvote 0
Great, thank you! I have been trying to get the concatenate portion to work with multiple errors depending on what type I assigned to "FullName," (it is currently set as object). Now, I am getting a Subscript Out of Range error on the first With statement. That line was not an issue until now.

I am also getting a Type 13 mismatch on
VBA Code: 
FullName(Cl.Value) = Cells(Cl, "G").Value & " " & Cells(Cl, "H").Value
but when I pull both sides into Watches, they both show as Type Variant/Integer

Here is the full current code:

VBA Code: 
Option Explicit
Sub ReturnTopTen()
    Dim Cl As Range
    Dim Dary(1 To 3) As Object
    Dim i As Long, j As Long, r As Long
    Dim Mx As Double
    Dim Ary As Variant
    Dim FullName As Object

For i = 1 To 3
        Set Dary(i) = CreateObject("scripting.dictionary")
   Next i
   With Sheets("DataAnalysis")
      For Each Cl In .Range("U2", .Range("U" & Rows.Count).End(xlUp))
         Dary(1)(Cl.Value) = Dary(1)(Cl.Value) + Cl.Offset(, -7).Value
         Dary(2)(Cl.Offset(, 8).Value) = Dary(2)(Cl.Offset(, 8).Value) + Cl.Offset(, -7).Value
         FullName(Cl.Value) = Cells(Cl, "G").Value & " " & Cells(Cl, "H").Value
         Dary(3)(FullName(Cl.Value)) = Dary(3)(FullName(Cl.Value)) + Cl.Offset(, -7).Value
      Next Cl
   End With
   With Sheets("Top10")
      .Range("A1:B1").Value = Array("Supplier", "Supplier Spend")
      .Range("D1:E1").Value = Array("Category", "Category Spend")
      .Range("G1:H1").Value = Array("Card Holder", "User Spend")
      For j = 1 To 3
         r = 0
         Mx = Application.Large(Dary(j).Items, 10)
         ReDim Ary(1 To 10, 1 To 2)
         For i = 0 To Dary(j).Count - 1
            If Dary(j).Items()(i) >= Mx Then
               r = r + 1
               Ary(r, 1) = Dary(j).Keys()(i)
               Ary(r, 2) = Dary(j).Items()(i)
            End If
         Next i
         With .Cells(2, Choose(j, 1, 4, 7))
            .Resize(10, 2).Value = Ary
            .Offset(-1).Resize(11, 2).Sort Key1:=.Offset(-1, 1), Order1:=xlDescending, Header:=xlYes
         End With
      Next j
    End With

End Sub
 
Upvote 0
How about
VBA Code: 
    Dim FullNme As String

   For i = 1 To 3
        Set Dary(i) = CreateObject("scripting.dictionary")
   Next i
   With Sheets("DataAnalysis")
      For Each Cl In .Range("U2", .Range("U" & Rows.Count).End(xlUp))
         Dary(1)(Cl.Value) = Dary(1)(Cl.Value) + Cl.Offset(, -7).Value
         Dary(2)(Cl.Offset(, 8).Value) = Dary(2)(Cl.Offset(, 8).Value) + Cl.Offset(, -7).Value
         FullNme = Cl.Offset(, -14).Value & "|" & Cl.Offset(, -13).Value
         Dary(3)(FullNme) = Dary(3)(FullNme) + Cl.Offset(, -7).Value
      Next Cl
   End With
 
Upvote 0
Now I get a Run-Time error 91: Object variable or With block variable not set for
VBA Code: 
FullNme = Cl.Offset(, -14).Value & "|" & Cl.Offset(, -13).Value

I updated the dim statement for FullNme too
 
Upvote 0
Did you make it a String Variable, as shown in post#16?
 
Upvote 0
You're welcome & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
301
STARL0RD
S
C
  • Question Question
Populating different sheets based on the value in a column on another sheet.
Replies
3
Views
600
DanteAmor
DanteAmor
P
  • Question Question
Return a value from a table that is in the top n percent of a person's trial scores
2
Replies
13
Views
883
Fluff
Fluff
I
  • Question Question
Find the second highest attribute based on criteria. I know its a combo of index(match(large, but I just can't get it to work correctly.
Replies
1
Views
487
StephenCrump
S
M
  • Question Question
Returning Values Based on Referent Cells (Avoiding Redundant Values)
Replies
5
Views
496
Fluff
Fluff

Forum statistics

Threads
1,222,602
Messages
6,167,003
Members
452,089
Latest member
seiexcel

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top