VBA Countif taking too long thinking maybe Dictionary?

Question

I have 200,000 rows of data. I am using a button in Amount sheet that will run a macro using SUMIF and COUNTIF and it takes forever to run. Can anyone offer me a different solution? Thanks in advance!

Currently I am using this code:

Sub Status()

 
 Dim my_range As String, rng1 As String, rng2 As String
 LR = Cells(Rows.Count, "B").End(xlUp).Row
 R = 6

ActiveSheet.Range("C6").FormulaR1C1 = "=COUNTIF(Invoice!C2,Amount!RC[-1])"
ActiveSheet.Range("D6").FormulaR1C1 = "=SUMIF(Invoice!C2,Amount!RC2,Invoice!C6)"
ActiveSheet.Range("E6").FormulaR1C1 = "=SUMIF(Invoice!C2,Amount!RC2,Invoice!C7)"
ActiveSheet.Range("F6").FormulaR1C1 = "=SUMIF(Invoice!C2,Amount!RC2,Invoice!C8)"


Do While R < LR
If Cells(R, 2) <> "" Then

rng1 = "C" & R + 1
rng2 = "F" & R + 1
my_range = rng1 & ":" & rng2

Application.range(my_range).Select
Selection.FillDown

End If
R = R + 1

Loop
End Sub

Answer 1

A generalized approach which will summarize a range according to one or more "key" columns, and return a count of each key, plus the sum from each of the specified "value" columns.

Sub Tester()

    Dim wsData As Worksheet, wsSumm As Worksheet, rngData As Range
    Dim dict As Object, t, arrOut, n As Long, tmp, k
    
    Set dict = CreateObject("scripting.dictionary")
    Set wsSumm = ThisWorkbook.Worksheets("Summary") 'output goes here
    Set wsData = ThisWorkbook.Worksheets("Invoice") 'data to be summarized
    
    'DummyData wsData 'set up some dummy data if needed
    
    t = Timer
    Set rngData = wsData.Range("A1").CurrentRegion                    'source data table
    Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1) 'exclude headers
    
    Set dict = SummarizeByKey(rngData, Array(1, 2), Array(6, 7, 8)) 'get summarized data (composite key)
    'Set dict = SummarizeByKey(rngData, Array(2), Array(6, 7, 8)) 'get summarized data (simple key)
    
    
    'transfer the dictionary output into an array so we can put it on a sheet
    ReDim arrOut(1 To dict.Count, 1 To 5) '5 = key, count, and 3 totals per key
    n = 0
    For Each k In dict
        n = n + 1
        arrOut(n, 1) = k      'key (simple or composite)
        tmp = dict(k)
        arrOut(n, 2) = tmp(0) 'count
        arrOut(n, 3) = tmp(1) 'sum #1
        arrOut(n, 4) = tmp(2) 'sum #2
        arrOut(n, 5) = tmp(3) 'sum #3
    Next k
    
    With wsSumm.Range("A2")
        .Resize(dict.Count, 5).Value = arrOut 'put the summary data on the sheet
    End With
    
    Debug.Print "Done", Timer - t
    
End Sub

'Given a range `rngData`, return a Dictionary keyed on data from one or more column indexes specified in `keyCols`,
'  where each dictionary value is an array containing the number of rows for that key, and a sum 
' for each column index specified in `valueCols`
Function SummarizeByKey(rngData As Range, keyCols, valueCols) As Object
    Dim allKeys As Boolean, frm As String, sep As String, i As Long, arrKeys, n As Long, vals, k
    Dim dict As Object, c As Long, tmp, v
    Set dict = CreateObject("scripting.dictionary")
    
    For i = 0 To UBound(keyCols) 'create keys from one or more columns specified in `keyCols`
        frm = frm & sep & rngData.Columns(keyCols(i)).Address
        sep = "&""|""&"
    Next i
    arrKeys = rngData.Worksheet.Evaluate(frm)
    
    ReDim vals(0 To UBound(valueCols))
    For i = 0 To UBound(valueCols)  'read each value column into an array
        vals(i) = rngData.Columns(valueCols(i)).Value
    Next i
    
    For i = 1 To UBound(arrKeys) 'loop over the keys array
        k = CStr(arrKeys(i, 1))
        If Not dict.Exists(k) Then dict(k) = EmptyArray(UBound(valueCols) + 1) 'for count and sum(s)
        tmp = dict(k)
        tmp(0) = tmp(0) + 1
        For c = 0 To UBound(valueCols)
            v = vals(c)(i, 1)
            If IsNumeric(v) Then tmp(c + 1) = tmp(c + 1) + v
        Next c
        dict(k) = tmp
    Next i
    Set SummarizeByKey = dict
End Function

'Utility: return an empty array with upper bound `sz`
Function EmptyArray(sz As Long)
    Dim rv
    ReDim rv(0 To sz)
    EmptyArray = rv
End Function

'create some dummy data for texting
Sub DummyData(ws As Worksheet)
    Const NUM_ROWS As Long = 100000
    Const NUM_COLS As Long = 10
    Dim rng As Range
    ws.Cells.ClearContents
    Set rng = ws.Range("A1").Resize(1, NUM_COLS)
    rng.Value = Evaluate("=""Col_"" & column(" & rng.Address & ")") 'add some headers
    With ws.Range("A2").Resize(NUM_ROWS, NUM_COLS)
        .Columns(1).Formula = "=""ID_"" & text(randbetween(1,10),""00"")" 'key column
        .Columns(2).Formula = "=""ID2_"" & text(randbetween(1,5),""00"")" 'key column#2
        .Columns(3).Resize(, 3).Value = "blah"
        .Columns(6).Resize(, 3).Formula = "=RAND()*100" 'some values to sum
        .Columns(9).Resize(, 2).Value = "blah"
        .Value = .Value
    End With
End Sub