Looping through CountIfs very slow using VBA

[newbi004]

Hi

I have the following code to loop though data to perform a series of CountIfs and fill specific cells with the results. However, this is very slow with 100 rows of data and I am concerned that it will be even slower when the number of rows become hundreds or even several thousand.

Could someone suggest a way to improve performance? I was wondering if arrays could be the answer?

The principle is that all the data is in Sheet4. My criteria is to count the number of occurrences the Department 1 to Department 6 against each of the codes LFT, CAV, EXO, EXL, EXC and REM.

The code that I have at the moment (which works very slowly!) is :

Dim lastRow As Long
    
    With Sheet4
        
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
    End With
    
    Sheet1.Range("C3").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 1", Sheet4.Range("E1:E" & lastRow), "LFT")
    Sheet1.Range("C4").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 1", Sheet4.Range("E1:E" & lastRow), "CAV")
    Sheet1.Range("C5").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 1", Sheet4.Range("E1:E" & lastRow), "EXO")
    Sheet1.Range("C6").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 1", Sheet4.Range("E1:E" & lastRow), "EXL")
    Sheet1.Range("C7").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 1", Sheet4.Range("E1:E" & lastRow), "EXC")
    Sheet1.Range("C8").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 1", Sheet4.Range("E1:E" & lastRow), "REM")
    
    Sheet1.Range("D3").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 2", Sheet4.Range("E1:E" & lastRow), "LFT")
    Sheet1.Range("D4").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 2", Sheet4.Range("E1:E" & lastRow), "CAV")
    Sheet1.Range("D5").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 2", Sheet4.Range("E1:E" & lastRow), "EXO")
    Sheet1.Range("D6").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 2", Sheet4.Range("E1:E" & lastRow), "EXL")
    Sheet1.Range("D7").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 2", Sheet4.Range("E1:E" & lastRow), "EXC")
    Sheet1.Range("D8").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 2", Sheet4.Range("E1:E" & lastRow), "REM")
    
    Sheet1.Range("E3").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 3", Sheet4.Range("E1:E" & lastRow), "LFT")
    Sheet1.Range("E4").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 3", Sheet4.Range("E1:E" & lastRow), "CAV")
    Sheet1.Range("E5").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 3", Sheet4.Range("E1:E" & lastRow), "EXO")
    Sheet1.Range("E6").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 3", Sheet4.Range("E1:E" & lastRow), "EXL")
    Sheet1.Range("E7").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 3", Sheet4.Range("E1:E" & lastRow), "EXC")
    Sheet1.Range("E8").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 3", Sheet4.Range("E1:E" & lastRow), "REM")
    
    Sheet1.Range("F3").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 4", Sheet4.Range("E1:E" & lastRow), "LFT")
    Sheet1.Range("F4").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 4", Sheet4.Range("E1:E" & lastRow), "CAV")
    Sheet1.Range("F5").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 4", Sheet4.Range("E1:E" & lastRow), "EXO")
    Sheet1.Range("F6").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 4", Sheet4.Range("E1:E" & lastRow), "EXL")
    Sheet1.Range("F7").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 4", Sheet4.Range("E1:E" & lastRow), "EXC")
    Sheet1.Range("F8").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 4", Sheet4.Range("E1:E" & lastRow), "REM")
    
    Sheet1.Range("G3").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 5", Sheet4.Range("E1:E" & lastRow), "LFT")
    Sheet1.Range("G4").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 5", Sheet4.Range("E1:E" & lastRow), "CAV")
    Sheet1.Range("G5").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 5", Sheet4.Range("E1:E" & lastRow), "EXO")
    Sheet1.Range("G6").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 5", Sheet4.Range("E1:E" & lastRow), "EXL")
    Sheet1.Range("G7").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 5", Sheet4.Range("E1:E" & lastRow), "EXC")
    Sheet1.Range("G8").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 5", Sheet4.Range("E1:E" & lastRow), "REM")
    
    Sheet1.Range("H3").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 6", Sheet4.Range("E1:E" & lastRow), "LFT")
    Sheet1.Range("H4").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 6", Sheet4.Range("E1:E" & lastRow), "CAV")
    Sheet1.Range("H5").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 6", Sheet4.Range("E1:E" & lastRow), "EXO")
    Sheet1.Range("H6").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 6", Sheet4.Range("E1:E" & lastRow), "EXL")
    Sheet1.Range("H7").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 6", Sheet4.Range("E1:E" & lastRow), "EXC")
    Sheet1.Range("H8").Value = WorksheetFunction.CountIfs(Sheet4.Range("C1:C" & lastRow), "Department 6", Sheet4.Range("E1:E" & lastRow), "REM")
    
End Sub

Thanks

[Norie]

There's no looping in that code.

Have you tried using a pivot table to get the results you want?

In the pivot department would be a row field, code a column field and count of code a data field.

[newbi004]

You are right, Norie. It doesn't loop! Just hard-coded.

Of course, pivot tables will be the answer. I will try that avenue.

Thanks for your reply

[berlan]

Here's a looping alternative (untested):

Sub main()

    Dim LR As Long, CalcMode As Long, i As Integer, j As Integer
    Dim rng1 As Range, rng2 As Range, str1 As String, str2 As String

    CalcMode = Application.Calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With Sheet4
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rng1 = .Range("C1:C" & LR)
        Set rng2 = .Range("E1:E" & LR)
        For i = 1 To 6
            str1 = Choose(i, "Department 1", "Department 2", "Department 3", "Department 4", "Department 5", "Department 6")
            str2 = Choose(i, "LFT", "CAV", "EXO", "EXL", "EXC", "REM")
            For j = 3 To 7        'loop from col C to col G
                Sheet1.Cells(2 + i, j).Value = Application.CountIfs(rng1, str1, rng2, str2)
            Next j
        Next i
    End With

    Application.ScreenUpdating = True
    Application.Calculation = CalcMode

End Sub

[newbi004]

Berlan

Sorry about the delay in getting back. I was testing your code and it took me a bit longer because you have introduced me to a new vba coding with Choose. I didn't know about that. Thanks for taking the time to help me.

Your code has made the procedure much more compact and incorporated a 'proper loop'. It was much faster than mine.

Cheers