Is there a faster CountIF

Question

As the title says. Is there any function or VBA code which does the same function as a countif and is a lot faster. Currently in the middle of massive countif and it is just

Answer 1

Try sumproduct(countif(x:x,y:y))
It’s slightly faster but by how much I am not sure.
Also let us know if you have found a better option out there.

Answer 2

If you can do without a count of the occurances and simply wish to check if the value x exists in the column of y's, then returning a boolean TRUE or FALSE with the ISNUMBER function evaluating a MATCH function lookup will greatly speed up the process.

=ISNUMBER(MATCH(S1, Y:Y, 0))

Fill down as necessary to catch all returns. Sort and/or filter the returned values to tabulate results.

Addendum:

Apparently there is. The huge improvement in the MATCH function calculation times over the COUNTIF function made me wonder if MATCH couldn't be put into a loop, advancing the first cell in its lookup_array parameter to the previously returned row number plus one until there were no more matches. Additionally, subsequent MATCh calls to lookup the same number (increasing the count) could be made to increasingly smaller lookup_array cell ranges by resizing (shrinking) the height of the column by the returned row number as well. If the processed values and their counts were stored as keys and items in a scripting dictionary, duplicate values could be instantly resolved without processing a count.

Sub formula_countif_test()
    Dim tmr As Double
    appOFF
    tmr = Timer
    With Sheet2.Cells(1, 1).CurrentRegion
        With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
            .Cells(1, 3).Resize(.Rows.Count, 1).FormulaR1C1 = _
                "=countif(c1, rc2)"  'no need for calculate when blocking in formulas like this
        End With
    End With
    Debug.Print "COUNTIF formula: " & Timer - tmr
    appON
End Sub

Sub formula_match_test()
    Dim rw As Long, mrw As Long, tmr As Double, vKEY As Variant
    'the following requires Tools, References, Microsoft Scripting Dictionary
    Dim dVALs As New Scripting.dictionary
    
    dVALs.CompareMode = vbBinaryCompare  'vbtextcompare for non-case sensitive
    
    appOFF
    tmr = Timer
    
    With Sheet2.Cells(1, 1).CurrentRegion
        With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) 'skip header
            For rw = 1 To .Rows.Count
                vKEY = .Cells(rw, 2).Value2
                If Not dVALs.Exists(vKEY) Then
                    dVALs.Add Key:=vKEY, _
                        Item:=Abs(IsNumeric(Application.Match(vKEY, .Columns(1), 0)))
                    If CBool(dVALs.Item(vKEY)) Then
                        mrw = 0: dVALs.Item(vKEY) = 0
                        Do While IsNumeric(Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0))
                            mrw = mrw + Application.Match(vKEY, .Columns(1).Offset(mrw, 0).Resize(.Rows.Count - mrw + 1, 1), 0)
                            dVALs.Item(vKEY) = CLng(dVALs.Item(vKEY)) + 1
                        Loop
                    End If
                    .Cells(rw, 3) = CLng(dVALs.Item(vKEY))
                Else
                    .Cells(rw, 3) = CLng(dVALs.Item(vKEY))
                End If
            Next rw
        End With
    End With
    Debug.Print "MATCH formula: " & Timer - tmr
    dVALs.RemoveAll: Set dVALs = Nothing
    appON
End Sub

Sub appON(Optional ws As Worksheet)
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub appOFF(Optional ws As Worksheet)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

        

I used 10K rows with columns A and B filled by RANDBETWEEN(1, 999) then copied and pasted as values.

Elapsed times:
 
    Test 1¹ - 10K rows × 2 columns filled with RANDBETWEEN(1, 999)
        COUNTIF formula:           15.488 seconds
        MATCH formula:                1.592 seconds 
 
    Test 2² - 10K rows × 2 columns filled with RANDBETWEEN(1, 99999)
        COUNTIF formula:           14.722 seconds
        MATCH formula:                3.484 seconds 
 
I also copied the values from the COUNTIF formula into another column and compared them to the ones returned by the coded MATCH function. They were identical across the 10K rows. 
   ¹ ^{More multiples; less zero counts} 
   ² ^{More zero counts, less multiples} 

While the nature of the data clearly makes a significant difference, the coded MATCH function outperformed the native COUNTIF worksheet function every time.

Don't forget the VBE's Tools ► References ► Microsoft Scripting Dictionary.

Answer 3

There is an easy workaround for COUNTIF, after sorting the data. You may add this to your VB Script, and run. For data with around 1 lakh line items, normal COUNTIF takes almost 10-15 mins. This script will get the counts in <10 secs.

Sub alternateFunctionForCountIF()
    Dim DS As Worksheet
    Set DS = ThisWorkbook.ActiveSheet
    
    Dim lcol As Integer
    lcol = DS.Cells(1, Columns.Count).End(xlToLeft).Column
    Dim fieldHeader As String
    
    Dim lrow As Long, i As Long, j As Long
    Dim countifCol As Integer, fieldCol As Integer
    
    fieldHeader = InputBox("Enter the column header to apply COUNTIF")
    If Len(fieldHeader) = 0 Then
        MsgBox ("Invalid input. " & Chr(13) & "Please enter the column header text and try again")
        Exit Sub
    End If
    For i = 1 To lcol
        If fieldHeader = DS.Cells(1, i).Value Then
            fieldCol = i
            Exit For
        End If
    Next i
    If fieldCol = 0 Then
        MsgBox (fieldHeader & " could not be found among the headers. Please enter a valid column header")
        Exit Sub
    End If
    
    countifCol = fieldCol + 1
    lrow = DS.Cells(Rows.Count, "A").End(xlUp).Row
    DS.Range(DS.Cells(1, countifCol).EntireColumn, DS.Cells(1, countifCol).EntireColumn).Insert
    DS.Cells(1, countifCol) = fieldHeader & "_count"
    
    DS.Sort.SortFields.Clear
    DS.Sort.SortFields.Add Key:=Range(DS.Cells(2, fieldCol), DS.Cells(lrow, fieldCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With DS.Sort
        .SetRange Range(DS.Cells(1, 1), DS.Cells(lrow, lcol))
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Dim startPos As Long, endPos As Long
    Dim checkText As String
    For i = 2 To lrow
        checkText = LCase(CStr(DS.Cells(i, fieldCol).Value))
        
        If (checkText <> LCase(CStr(DS.Cells(i - 1, fieldCol).Value))) Then
            startPos = i
        End If
        If (checkText <> LCase(CStr(DS.Cells(i + 1, fieldCol).Value))) Then
            endPos = i
            For j = startPos To endPos
                 DS.Cells(j, countifCol) = endPos - startPos + 1
            Next j
        End If
    Next i
    MsgBox ("Done")
End Sub