SUMIFS faster in vba array and scripting.dictionary-CodePudding

I want to use the vba sumifs array and scripting.dictionary because there are a hundred thousand records there may be the best solution. For information sheet "DBALL" is the source and sheet "RECON" is the result. I also found the vba code below but it doesn't match the result.

info formula sheet "RECON" column B "In" = SUMIFS(DBALL!$A$2:$A$5,DBALL!$C$2:$C$5,RECON!$A2,DBALL!$B$2:$B$5,RECON!B$1)

info formula sheet "RECON" column c "Out" = SUMIFS(DBALL!$A$2:$A$5,DBALL!$C$2:$C$5,RECON!$A2,DBALL!$B$2:$B$5,RECON!C$1)

info formula sheet "RECON" column d "difference" = B2-C2

Thanks

  Sub SUMIFSFASTER()
    
    Dim arr, ws, rng As Range, keyCols, valueCol As Long, destCol As Long, i As Long, frm As String, sep As String
    Dim t, dict, arrOut(), arrValues(), v, tmp, n As Long
    
    keyCols = Array(2, 3)  'these columns form the composite key
    valueCol = 1             'column with values (for sum)
    destCol = 4               'destination for calculated values
    
    t = Timer
    
    Set ws = Sheets("DBALL")
    Set rng = ws.Range("A1").CurrentRegion
    n = rng.Rows.Count - 1
    Set rng = rng.Offset(1, 0).Resize(n) 'exclude headers
    
    'build the formula to create the row "key"
    For i = 0 To UBound(keyCols)
        frm = frm & sep & rng.Columns(keyCols(i)).Address
        sep = "&""|""&"
    Next i
    arr = ws.Evaluate(frm)  'get an array of composite keys by evaluating the formula
    arrValues = rng.Columns(valueCol).Value  'values to be summed
    ReDim arrOut(1 To n, 1 To 1)             'this is for the results
    
    Set dict = CreateObject("scripting.dictionary")
    'first loop over the array counts the keys
    For i = 1 To n
        v = arr(i, 1)
        If Not dict.exists(v) Then dict(v) = Array(0, 0) 'count, sum
        tmp = dict(v) 'can't modify an array stored in a dictionary - pull it out first
        tmp(0) = tmp(0)   1                 'increment count
        tmp(1) = tmp(1)   arrValues(i, 1)   'increment sum
        dict(v) = tmp                       'return the modified array
    Next i
    
    'second loop populates the output array from the dictionary
    For i = 1 To n
        arrOut(i, 1) = dict(arr(i, 1))(1)                       'sumifs
        'arrOut(i, 1) = dict(arr(i, 1))(0)                      'countifs
        'arrOut(i, 1) = dict(arr(i, 1))(1) / dict(arr(i, 1))(0) 'averageifs
    Next i
    'populate the results
    rng.Columns(destCol).Value = arrOut
    
    Debug.Print "Checked " & n & " rows in " & Timer - t & " secs"

End Sub

Source

RESULT

RESULT result with add code

CodePudding user response：

As said in the comments a better solution is probably to use a pivot table resp. power pivot.

If you are after a solution with VBA and want to use a dictionary I would probably use the following code.

First you need to create a class cVal which stores the values you are after

Option Explicit

Public qtyIn As Double
Public qtyOut As Double

Then you can use the following code

Option Explicit

Sub useDict()

    Const COL_VAL = 1
    Const COL_INOUT = 2
    Const COL_COMBINE = 3
    Const GRO_IN = "IN"
    Const GRO_OUT = "OUT"

    Dim rg As Range, ws As Worksheet
    
    ' Get the range with the data
    Set ws = Worksheets("DBALL")
    Set rg = ws.Range("A1").CurrentRegion
    Set rg = rg.Offset(1, 0).Resize(rg.Rows.Count - 1)
        
    Dim vDat As Variant
    vDat = rg
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim Key As Variant, gro As Variant
    Dim i As Long, sngVal  As cVal
    For i = LBound(vDat, 1) To UBound(vDat, 1)
    
        ' Key of the dictionary
        Key = vDat(i, COL_COMBINE)
        ' trim the value and do not consider upper/lower case
        gro = UCase(Trim(vDat(i, COL_INOUT)))
                
        If dict.Exists(Key) Then
            ' just increase the "member" values of the already stored object
            Set sngVal = dict(Key)
            With sngVal
                If gro = GRO_IN Then
                    .qtyIn = .qtyIn   vDat(i, COL_VAL)
                End If
                If gro = GRO_OUT Then
                    .qtyOut = .qtyOut   vDat(i, COL_VAL)
                End If
            End With
        
        Else
            ' Create a new object which stores the summed values for "IN" resp "OUT"
            Set sngVal = New cVal
            With sngVal
                If gro = GRO_IN Then
                    .qtyIn = vDat(i, COL_VAL)
                End If
                If gro = GRO_OUT Then
                    .qtyOut = vDat(i, COL_VAL)
                End If
            End With
            dict.Add Key, sngVal

        End If
    
    Next i
    
    
    ' write Dictionary
    
    ' put the values of the dictionary in an array
    ' this is faster than writing each single line directly to the sheet
    ReDim vDat(1 To dict.Count, 1 To 4)
    i = 1
    For Each Key In dict.Keys
        vDat(i, 1) = Key
        vDat(i, 2) = dict(Key).qtyIn
        vDat(i, 3) = dict(Key).qtyOut
        vDat(i, 4) = Abs(dict(Key).qtyIn - dict(Key).qtyOut)
        i = i   1
    Next Key
    
    'write Header
    Set rg = Worksheets("RECON").Range("A1")
    Set rg = rg.Resize(, 4)
    rg.Clear
    rg = Array("COMBINE", "In", "Out", "Diff")
        
    Set rg = Worksheets("RECON").Range("A2")
    Set rg = rg.Resize(dict.Count, 4)
    rg.Clear
    rg = vDat

    ' PS Code to add a sum row below the data
    Set rg = Worksheets("RECON").Range("A" & dict.Count   2)
    Set rg = rg.Resize(1, 4)
    rg.Clear

    'rg.Columns(1).Value = "Total"

    Dim bSum As Double, rDat As Variant
    rDat = Application.Index(vDat, , 2)
    bSum = WorksheetFunction.sum(rDat)
    rg.Columns(2).Value = bSum

    rDat = Application.Index(vDat, , 3)
    bSum = WorksheetFunction.sum(rDat)
    rg.Columns(3).Value = bSum

    rDat = Application.Index(vDat, , 4)
    bSum = WorksheetFunction.sum(rDat)
    rg.Columns(4).Value = bSum

End Sub

But I doubt that to be faster than a Pivot Table