CODEWITHSUNDEEP
vbaperformanceexcel
AmadeusNing
AmadeusNing

Reputation: 107

Excel VBA - How to do countif more efficiently?

I am working on an Excel VBA code for a spreadsheet. The aim of the following code is to count how many times the voucher number in this row appears in the whole column G. As the raw data has more than 60,000 rows, the following code will take more than 2 mins to finish. 

Worksheets("Raw Data").Range("AP2:AP" & lastrow).Formula = "=IF(AO2=""MATCHED"",""MATCHED"",IF((COUNTIF(AQ_u,G2))>0,""MATCHED"",""NOT MATCHED""))"

I also tried an alternatvie way, which basically is also a CountIF function:

Dim cel, rng As Range
Set rng = Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
For Each cel In Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
     If Application.WorksheetFunction.CountIf(rng, cel.Offset(0, -36).Value) > 0 Then
        cel.Offset(0, -1).Value = 1
     End If
Next cel

Both of the codes above take a long time to finish, so I am wondering whether there is a way to make the code more efficient? Many thanks.

Upvotes: 1

Views: 2595

Answers (1)

paul bica
paul bica

Reputation: 10705

Try the code bellow (it uses an array and a dictionary)

For dictionaries late binding is slow: CreateObject("Scripting.Dictionary")

Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime

Option Explicit

Public Sub CountVouchers()
    Const G     As Long = 7     'col G
    Const AQ    As Long = 43    'col AQ

    Dim ws  As Worksheet:   Dim i  As Long:     Dim d As Dictionary
    Dim arr As Variant:     Dim lr As Long:     Dim t As Double

    t = Timer:              Set d = New Dictionary

    Set ws = ThisWorkbook.Worksheets("Raw Data")
    lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
    ws.Columns("AP").Clear

    arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ))                'Range to Array
        For i = 2 To lr
            If Len(Trim(arr(i, AQ))) > 0 Then d(CStr(arr(i, AQ))) = 1
        Next
        For i = 2 To lr
            If d.Exists(CStr(arr(i, G))) Then arr(i, AQ - 1) = 1    'Count
        Next
    ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr                'Array back to Range

Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"

    'Rows: 100,001, Time: 1.773 sec

End Sub

If you want to see total number of occurrences for each voucher:

Public Sub CountVoucherOccurrences()
    Const G     As Long = 7
    Const AQ    As Long = 43

    Dim ws  As Worksheet:   Dim i  As Long:     Dim d As Dictionary
    Dim arr As Variant:     Dim lr As Long:     Dim t As Double

    t = Timer:              Set d = New Dictionary

    Set ws = ThisWorkbook.Worksheets("Raw Data")
    lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
    ws.Columns("AP").Clear

    arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ))
        For i = 2 To lr
            d(arr(i, AQ)) = IIf(Not d.Exists(arr(i, AQ)), 1, d(arr(i, AQ)) + 1)
        Next
        For i = 2 To lr
           If d.Exists(arr(i, G)) Then arr(i, AQ - 1) = d(arr(i, AQ))
        Next
    ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr

Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"

    'Rows: 100,001, Time: 1.781 sec

End Sub

Upvotes: 1

Related Questions