VBA: Sum up multiple values versus Sumifs

F

FryGirl

Well-known Member
Joined
Nov 11, 2008
Messages
1,362
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I'm currently using VBA code to produce unique values in column D starting in D2 (Sheet2). This works great, but taking the next step, I'm using a Sumifs formula to create an org chart type summation for that office in Column E at E2..

Here is a small snippet of what I'm trying to accomplish. In the results table, as you can see I'm using a Sumifs to calculate the totals. Hoping this can be done with VBA versus the Sumifs!

Source
Testing Org Chart.xlsm
BEAAAO
1Hdr1Hdr2Hdr3QTR
2OFFICELLO1
3OFFICEXCFA1
4OFFICEXCFA1
5OFFICEDPXO1
6OFFICEDPXA1
7OFFICEDPXC1
8OFFICEDPXA1
9OFFICEDPXA1
10OFFICEDPXC1
11OFFICEDPXA1
12OFFICEDPXA1
Chart


Result
Testing Org Chart.xlsm
CDE
1Hdr1Hdr2Hdr3
2OFFICELL1/0/0/1
3XCF0/2/0/2
4DPX1/5/2/8
Sheet2
Cell Formulas
RangeFormula
E2:E4E2=SUMIFS(Chart!AO:AO,Chart!B:B,Sheet2!$C$2,Chart!AA:AA,"O",Chart!E:E,Sheet2!D2)&"/"& SUMIFS(Chart!AO:AO,Chart!B:B,Sheet2!$C$2,Chart!AA:AA,"A",Chart!E:E,Sheet2!D2)&"/"& SUMIFS(Chart!AO:AO,Chart!B:B,Sheet2!$C$2,Chart!AA:AA,"C",Chart!E:E,Sheet2!D2)&"/"& SUMIFS(Chart!AO:AO,Chart!B:B,Sheet2!$C$2,Chart!E:E,Sheet2!D2)


VBA Code: 
Sub FilterLevel1()
    Dim Dn As Range
    Dim rng As Range: Set rng = Sheet1.Range("E2", Sheet1.Range("E" & Sheet1.Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        For Each Dn In rng
            If Not .Exists(Dn.Value) _
                And Dn.Offset(, -3).Value = Sheets("Sheet2").Range("C2").Value Then
                .Add Dn.Value, ""
            End If
        Next
        Sheet2.Cells(2, 5).Resize(.Count).Value = Application.Transpose(.keys)
    End With
End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
Something like this.

Book1
ABDEZAAANAOAPAQARASATAUAVAW
1Hdr1Hdr2Hdr3QTRHdr1Hdr2Hdr3Hdr1Hdr2Hdr3
2OFFICELLO1OFFICELL1/0/0/1OFFICEDPX1/5/2/8
3OFFICEXCFA1XCF0/2/0/2LL1/0/0/1
4OFFICEXCFA1DPX1/5/2/8XCF0/2/0/2
5OFFICEDPXO1ROOMLL1/1/1/3ROOMDPX0/1/1/2
6OFFICEDPXA1XCF1/0/1/2LL1/2/2/5
7OFFICEDPXC1DPX2/2/2/6XCF2/2/0/4
8OFFICEDPXA1
9OFFICEDPXA1
10OFFICEDPXC1
11OFFICEDPXA1
12OFFICEDPXA1
13ROOMDPXA1
14ROOMXCFO1
15ROOMLLA1
16ROOMDPXO1
17ROOMLLC1
18ROOMXCFO1
19ROOMXCFC1
20ROOMLLA1
21ROOMLLO1
22ROOMXCFC1
23ROOMXCFC1
Sheet3


VBA Code: 
Sub SI()
Dim LR As Long:     LR = Range("B" & Rows.Count).End(xlUp).Row
Dim SD As Object:   Set SD = CreateObject("Scripting.Dictionary")
Dim H1 As Object:   Set H1 = CreateObject("Scripting.Dictionary")
Dim H2 As Object:   Set H2 = CreateObject("Scripting.Dictionary")
Dim Pos As Integer: Pos = 1
Dim CNT(1 To 4) As Integer
Dim Res() As Variant
Dim AR() As Variant
Dim HS1 As String
Dim HS2 As String

For i = 1 To 4
    Select Case i
        Case 1
            AR = Range("B2:B" & LR).Value2
        Case 2
            AR = Range("E2:E" & LR).Value2
        Case 3
            AR = Range("AA2:AA" & LR).Value2
        Case 4
            AR = Range("AO2:AO" & LR).Value2
    End Select
    SD.Add i, AR
Next i

GetUnique H1, SD.items()(0)
GetUnique H2, SD.items()(1)
ReDim Res(1 To (H1.Count * H2.Count), 1 To 3)

For j = 0 To H1.Count - 1
    HS1 = H1.items()(j)
    For k = 0 To H2.Count - 1
        HS2 = H2.items()(k)
        For n = 1 To UBound(SD.items()(2))
            If SD.items()(0)(n, 1) = HS1 And SD.items()(1)(n, 1) = HS2 Then
                Select Case SD.items()(2)(n, 1)
                    Case "O"
                        CNT(1) = CNT(1) + 1
                    Case "A"
                        CNT(2) = CNT(2) + 1
                    Case "C"
                        CNT(3) = CNT(3) + 1
                End Select
            End If
        Next n
        CNT(4) = CNT(1) + CNT(2) + CNT(3)
        If Pos Mod 3 = 1 Then Res(Pos, 1) = HS1
        Res(Pos, 2) = HS2
        Res(Pos, 3) = Join(Array(CNT(1), CNT(2), CNT(3), CNT(4)), "/")
        Pos = Pos + 1
        Erase CNT
    Next k
Next j

Range("AQ2").Resize(UBound(Res), UBound(Res, 2)).Value = Res

End Sub

Sub GetUnique(SD As Object, AR As Variant)
For i = 1 To UBound(AR)
    If Not SD.exists(AR(i, 1)) Then SD.Add AR(i, 1), AR(i, 1)
Next i
End Sub

The green table was done using Power Query instead of VBA.

Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    Type = Table.TransformColumnTypes(Source,{{"Hdr1", type text}, {"Column1", type any}, {"Column2", type any}, {"Hdr2", type text}, {"Column3", type any}, {"Column4", type any}, {"Column5", type any}, {"Column6", type any}, {"Column7", type any}, {"Column8", type any}, {"Column9", type any}, {"Column10", type any}, {"Column11", type any}, {"Column12", type any}, {"Column13", type any}, {"Column14", type any}, {"Column15", type any}, {"Column16", type any}, {"Column17", type any}, {"Column18", type any}, {"Column19", type any}, {"Column20", type any}, {"Column21", type any}, {"Column22", type any}, {"Column23", type any}, {"Hdr3", type text}, {"Column24", type any}, {"Column25", type any}, {"Column26", type any}, {"Column27", type any}, {"Column28", type any}, {"Column29", type any}, {"Column30", type any}, {"Column31", type any}, {"Column32", type any}, {"Column33", type any}, {"Column34", type any}, {"Column35", type any}, {"Column36", type any}, {"QTR", Int64.Type}}),
    ROC = Table.SelectColumns(Type,{"Hdr1", "Hdr2", "Hdr3", "QTR"}),
    MC = Table.CombineColumns(ROC,{"Hdr1", "Hdr2"},Combiner.CombineTextByDelimiter("-", QuoteStyle.None),"Merged"),
    Pivot = Table.Pivot(MC, List.Distinct(MC[Hdr3]), "Hdr3", "QTR", List.Sum),
    Zero = Table.ReplaceValue(Pivot,null,0,Replacer.ReplaceValue,{"O", "A", "C"}),
    Total = Table.AddColumn(Zero, "Total", each [O]+[A]+[C]),
    MC2 = Table.CombineColumns(Table.TransformColumnTypes(Total, {{"O", type text}, {"A", type text}, {"C", type text}, {"Total", type text}}, "en-US"),{"O", "A", "C", "Total"},Combiner.CombineTextByDelimiter("/", QuoteStyle.None),"Hdr3"),
    Split = Table.SplitColumn(MC2, "Merged", Splitter.SplitTextByDelimiter("-", QuoteStyle.Csv), {"Merged.1.1", "Hdr2"}),
    Index = Table.AddIndexColumn(Split, "Index", 0, 1, Int64.Type),
    Hdr1 = Table.AddColumn(Index, "Hdr1", each try if Index[Merged.1.1]{[Index]-1} <> [Merged.1.1] then [Merged.1.1] else null otherwise [Merged.1.1]),
    RC = Table.RemoveColumns(Hdr1,{"Merged.1.1","Index"}),
    Reorder = Table.ReorderColumns(RC,{"Hdr1", "Hdr2", "Hdr3"})
in
    Reorder
 
Upvote 0
Hi lrobbo314, this works extremely well, but one request if I may.

Using your example posted above, for the table in AQ:AR, would it be possible to build it off of a value selected in AP2? I will eventually build all of this into a worksheet change event off of P2 which I can do no problem.

So example would be, user selects "Office" in P2
 
Upvote 0
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("P2"), Target) Is Nothing And Target.Cells.Count = 1 Then
        Dim LR As Long:     LR = Range("B" & Rows.Count).End(xlUp).Row
        Dim SD As Object:   Set SD = CreateObject("Scripting.Dictionary")
        Dim H2 As Object:   Set H2 = CreateObject("Scripting.Dictionary")
        Dim Pos As Integer: Pos = 1
        Dim CNT(1 To 4) As Integer
        Dim Res() As Variant
        Dim AR() As Variant
        Dim HS1 As String
        Dim HS2 As String
        
        For i = 1 To 4
            Select Case i
                Case 1
                    AR = Range("B2:B" & LR).Value2
                Case 2
                    AR = Range("E2:E" & LR).Value2
                Case 3
                    AR = Range("AA2:AA" & LR).Value2
                Case 4
                    AR = Range("AO2:AO" & LR).Value2
            End Select
            SD.Add i, AR
        Next i
        
        GetUnique H2, SD.items()(1)
        ReDim Res(1 To (H2.Count), 1 To 3)
        
    
        HS1 = Target.Value
        For k = 0 To H2.Count - 1
            HS2 = H2.items()(k)
            For n = 1 To UBound(SD.items()(2))
                If SD.items()(0)(n, 1) = HS1 And SD.items()(1)(n, 1) = HS2 Then
                    Select Case SD.items()(2)(n, 1)
                        Case "O"
                            CNT(1) = CNT(1) + 1
                        Case "A"
                            CNT(2) = CNT(2) + 1
                        Case "C"
                            CNT(3) = CNT(3) + 1
                    End Select
                End If
            Next n
            CNT(4) = CNT(1) + CNT(2) + CNT(3)
            If Pos Mod 3 = 1 Then Res(Pos, 1) = HS1
            Res(Pos, 2) = HS2
            Res(Pos, 3) = Join(Array(CNT(1), CNT(2), CNT(3), CNT(4)), "/")
            Pos = Pos + 1
            Erase CNT
        Next k
    
        
        Range("AQ2").Resize(UBound(Res), UBound(Res, 2)).Value = Res
End If
End Sub

Sub GetUnique(SD As Object, AR As Variant)
For i = 1 To UBound(AR)
    If Not SD.exists(AR(i, 1)) Then SD.Add AR(i, 1), AR(i, 1)
Next i
End Sub
 
Upvote 0
Thanks again for your help. I misspoke and it's actually AP2, but I've changed that. Anyway, it's producing the full results, not just the "value" selected in AP2. However, it does only sum up from the value in AP2.

Book1
APAQARAS
2ROOMROOMLL0/0/0/0
3XCF0/0/0/0
4DPX0/0/0/0
5ROOMDD1/0/0/1
6YYY0/2/0/2
7DPS1/5/2/8
Sheet1
Cells with Data Validation
CellAllowCriteria
AP2ListOFFICE,ROOM
 
Upvote 0
Not sure how that is possible. This is the result I'm getting when the code runs.

Book1
ABDEFPZAAANAOAPAQARAS
1Hdr1Hdr2Hdr3QTRHdr1Hdr2Hdr3
2OFFICELLO1OFFICEOFFICELL1/0/0/1
3OFFICEXCFA1XCF0/2/0/2
4OFFICEXCFA1DPX1/5/2/8
5OFFICEDPXO1
6OFFICEDPXA1
7OFFICEDPXC1
8OFFICEDPXA1
9OFFICEDPXA1
10OFFICEDPXC1
11OFFICEDPXA1
12OFFICEDPXA1
13ROOMXCFO1
14ROOMDPXA1
15ROOMXCFO1
16ROOMDPXO1
17ROOMLLC1
18ROOMXCFA1
19ROOMLLC1
20ROOMLLO1
21ROOMDPXA1
22ROOMXCFC1
23ROOMLLC1
Sheet3
Cells with Data Validation
CellAllowCriteria
AP2ListOFFICE,ROOM


VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("AP2"), Target) Is Nothing And Target.Cells.Count = 1 Then
        Dim LR As Long:     LR = Range("B" & Rows.Count).End(xlUp).Row
        Dim SD As Object:   Set SD = CreateObject("Scripting.Dictionary")
        Dim H2 As Object:   Set H2 = CreateObject("Scripting.Dictionary")
        Dim Pos As Integer: Pos = 1
        Dim CNT(1 To 4) As Integer
        Dim Res() As Variant
        Dim AR() As Variant
        Dim HS1 As String
        Dim HS2 As String
        
        For i = 1 To 4
            Select Case i
                Case 1
                    AR = Range("B2:B" & LR).Value2
                Case 2
                    AR = Range("E2:E" & LR).Value2
                Case 3
                    AR = Range("AA2:AA" & LR).Value2
                Case 4
                    AR = Range("AO2:AO" & LR).Value2
            End Select
            SD.Add i, AR
        Next i
        
        GetUnique H2, SD.items()(1)
        ReDim Res(1 To (H2.Count), 1 To 3)
        
        HS1 = Target.Value
        For k = 0 To H2.Count - 1
            HS2 = H2.items()(k)
            For n = 1 To UBound(SD.items()(2))
                If SD.items()(0)(n, 1) = HS1 And SD.items()(1)(n, 1) = HS2 Then
                    Select Case SD.items()(2)(n, 1)
                        Case "O"
                            CNT(1) = CNT(1) + 1
                        Case "A"
                            CNT(2) = CNT(2) + 1
                        Case "C"
                            CNT(3) = CNT(3) + 1
                    End Select
                End If
            Next n
            CNT(4) = CNT(1) + CNT(2) + CNT(3)
            If Pos Mod 3 = 1 Then Res(Pos, 1) = HS1
            Res(Pos, 2) = HS2
            Res(Pos, 3) = Join(Array(CNT(1), CNT(2), CNT(3), CNT(4)), "/")
            Pos = Pos + 1
            Erase CNT
        Next k
           
        Range("AQ2").Resize(UBound(Res), UBound(Res, 2)).Value = Res
End If
End Sub

Sub GetUnique(SD As Object, AR As Variant)
For i = 1 To UBound(AR)
    If Not SD.exists(AR(i, 1)) Then SD.Add AR(i, 1), AR(i, 1)
Next i
End Sub
 
Upvote 0
Solution
Well that was weird. I messed around and rerun it and it now does exactly as expected. Thank you so much for your valuable time.
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
VBA code modification sumif
Replies
2
Views
294
FGaxha
F
B
  • Question
How do I export charts based on conditions to PDF using VBA?
Replies
1
Views
713
John_w
J
montecarlo2012
  • Solved
using cells for less
Replies
5
Views
295
bebo021999
B
JohnPoole
  • Solved
Delete rows based on unique values
2
Replies
17
Views
867
kevin9999
K
sharky12345
  • Solved
Error trying to populate Userform Listbox
Replies
6
Views
434
RoryA
RoryA

Forum statistics

Threads
1,214,583
Messages
6,120,378
Members
448,955
Latest member
BatCoder

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