Article 30 – VBA – Approaches for Unique Count and Time Performance Results for the Same

As part of this article, we will look into various approaches for counting unique in VBA and also see what time do they take to determine the best approach on the basis of "Time Taken". I have used Charles William's MicroTimer for timing the time.

https://msdn.microsoft.com/en-us/library/aa730921%28v=office.12%29.aspx

We will see performance of these approaches with following number of records

– 100000
– 50000
– 33000
– 10000
– 1000
– 100

The Excel file related to this article can be downloaded from Article-30-Count-Unique-in-VBA. The VBA codes can be looked into Two Modules – Timer and CodeforCountUnique.

Sub TimerLog calls corresponding Procedure 10 Times and logs the result in the Excel Sheet. The Excel takes the averages of these results to arrive at the final timing.

Private Declare Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
Function MicroTimer() As Double
' Returns seconds.
    Dim cyTicks1 As Currency
    Static cyFrequency As Currency
    MicroTimer = 0
' Get frequency.
    If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
    getTickCount cyTicks1
' Seconds
    If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function

Sub TimerLog()
    Dim Timer As Double
    Dim RWs As Worksheet
    Dim LastRow As Long, i As Long
    Dim ColLetter As String: ColLetter = "Aj"
    Set RWs = Worksheets("Results")
    For i = 1 To 10
        LastRow = RWs.Range(ColLetter & "13").End(xlUp).Row
        Timer = MicroTimer()
        Call CountUniqueTransferToArrayLooping
        Cells(LastRow + 1, ColLetter) = 1000 * (MicroTimer() - Timer)
    Next i
End Sub

Approach 1 – Collection Approach

Collection approach uses Collection object in VBA to count Unique.

Sub CountUniqueCollection()
    Dim Ws As Worksheet
    Dim Col As New Collection
    Dim Cell As Range, Rng As Range
    Dim UniqueCount As Long
    Set Ws = Worksheets("100")
    Set Rng = Ws.Range("A2:A" & Ws.Range("A" & Rows.Count).End(xlUp).Row)
    For Each Cell In Rng
        On Error Resume Next
        Col.Add Cell, Key:=Cell
    Next Cell
    UniqueCount = Col.Count
    Debug.Print UniqueCount
End Sub

The time taken by this Procedure is as below –

Approach 2 – Dictionary Approach – Late Binding

We have used Late Binding first.

Sub CountUniqueDict()
    Dim Ws As Worksheet
    Dim Dict As Object
    Dim Cell As Range, Rng As Range
    Dim UniqueCount As Long
    Set Dict = CreateObject("Scripting.Dictionary")
    Set Ws = Worksheets("100")
    Set Rng = Ws.Range("A2:A" & Ws.Range("A" & Rows.Count).End(xlUp).Row)
    For Each Cell In Rng
       Dict(Cell.Value) = Cell.Value
    Next Cell
    UniqueCount = Dict.Count
    Debug.Print UniqueCount
End Sub

The time taken by this Procedure is as below –

Approach 3 – Dictionary Approach – Early Binding

We have used Early Binding and as expected it does offer performance gain over late binding.

Sub CountUniqueDictEB()
    Dim Ws As Worksheet
    Dim Cell As Range, Rng As Range
    Dim UniqueCount As Long
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Set Ws = Worksheets("100000")
    Set Rng = Ws.Range("A2:A" & Ws.Range("A" & Rows.Count).End(xlUp).Row)
    For Each Cell In Rng
       Dict(Cell.Value) = Cell.Value
    Next Cell
    UniqueCount = Dict.Count
    Debug.Print UniqueCount
End Sub

The time taken by this Procedure is as below –

Approach 4 – Formula Approach

This approach uses following SUMPRODUCT formula to count.

SUMPRODUCT((A2:A100<>"")/COUNTIF(A2:A100,A2:A100&""))

The above formula is upto 100. The formula was updated every time before the procedure was called to take care of the range. Hence, when sheet having 100000 records was called, the formula was updated to –

SUMPRODUCT((A2:A100000<>"")/COUNTIF(A2:A100000,A2:A100000&""))

Sub CountUniqueFormula()
    Dim Ws As Worksheet
    Dim LastRow As Long
    Dim Cell As Range, Rng As Range
    Dim UniqueCount As Long
    Set Ws = Worksheets("1000")
    UniqueCount = Ws.[SUMPRODUCT((A2:A100<>"")/COUNTIF(A2:A100,A2:A100&""))]
    Debug.Print UniqueCount
End Sub

The time taken by this Procedure is as below –

Approach 5 – Advanced Filter Approach

This formula applies advanced filter for unique records and counts unique.

Sub CountUniqueAdvFilter()
        Dim Ws As Worksheet
        Dim Rng As Range
        Dim UniqueCount As Long
        Set Ws = Worksheets("100")
        Ws.Columns("A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set Rng = Ws.Range("A2:A" & Ws.Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlVisible)
        UniqueCount = Rng.Cells.Count
        Debug.Print UniqueCount
        Ws.ShowAllData
End Sub

The time taken by this Procedure is as below –

Approach 6 – Remove Duplicates Approach

This formula used Remove Duplicates and then counts the unique.

Sub CountUniqueRemoveDup()
        Dim Ws As Worksheet
        Dim UniqueCount As Long
        Set Ws = Worksheets("100000")
        Application.ScreenUpdating = False
        Ws.Columns("A").Copy Ws.Range("B1")
        Ws.Columns("B").RemoveDuplicates Columns:=1, Header:=xlYes
        UniqueCount = Ws.Range("B" & Rows.Count).End(xlUp).Row - 1
        Ws.Columns("B").Clear
        Application.ScreenUpdating = True
        Debug.Print UniqueCount
End Sub

The time taken by this Procedure is as below –

Approach 7 – Looping within Worksheet Range Approach

The formula first sorts the records and then reads each and every record. Whenever it finds a new record, it counts them for unique records.

Sub CountUniqueLooping()
        Dim Ws As Worksheet
        Dim Cell As Range, Rng As Range
        Dim UniqueCount As Long
        Set Ws = Worksheets("100")
        Application.ScreenUpdating = False
        Ws.Columns("A").Copy Ws.Range("B1")
        Ws.Columns("B").Sort Key1:=Ws.Range("B1"), order1:=xlAscending, Header:=xlYes
        Set Rng = Ws.Range("B2:B" & Ws.Range("B" & Rows.Count).End(xlUp).Row)
        For Each Cell In Rng
            If Cell.Offset(-1, 0) <> Cell Then
                UniqueCount = UniqueCount + 1
            End If
        Next Cell
        Ws.Columns("B").Clear
        Application.ScreenUpdating = True
        Debug.Print UniqueCount
End Sub

The time taken by this Procedure is as below –

Approach 8 – Looping within Array by Transferring the Range to Array Approach

We know that for large numbers it is better to transfer to an Array and then loop through array rather than looping within the Worksheet Range itself. Hence, we transfer the contents to an Array and perform looping on that. The formula first sorts the records and transfers the range to an Array. Then it reads each and every record in the array. Whenever it finds a new record, it counts them for unique records.

Sub CountUniqueTransferToArrayLooping()
        Dim Ws As Worksheet
        Dim Cell As Range, Rng As Range
        Dim UniqueCount As Long, i As Long
        Dim Arr
        Set Ws = Worksheets("100")
        Application.ScreenUpdating = False
        Ws.Columns("A").Copy Ws.Range("B1")
        Ws.Columns("B").Sort Key1:=Ws.Range("B1"), order1:=xlAscending, Header:=xlYes
        Set Rng = Ws.Range("B2:B" & Ws.Range("B" & Rows.Count).End(xlUp).Row)
        Arr = Rng
        UniqueCount = 1
        For i = LBound(Arr) + 1 To UBound(Arr)
            If Arr(i - 1, 1) <> Arr(i, 1) Then
                UniqueCount = UniqueCount + 1
            End If
        Next i
        Ws.Columns("B").Clear
        Application.ScreenUpdating = True
        Debug.Print UniqueCount
End Sub

The time taken by this Procedure is as below –

Below is the result on the basis of above timings.

Least Time is marked in Green.
Second Least is marked in Yellow.
Third Least is marked in Orange.
Highest time is marked in Red.

Following is the conclusion –

1. Looping Array approach is best for Large Numbers. It is no. 1 >= 10000 records

2. Dictionary Early Binding approach is best for smaller numbers like 1000.

3. For very small numbers like 100, Collections is the best.

If you want to choose one single approach for any number of records, go for Looping Array

Now, below is a twist. We have seen Looping Array approach is the best to process records and our Collections / Dictionary approaches were looping through Worksheet range. Let's combine Looping Array with Collection / Dictionary and see whether there is a change.

Approach 9 – Collection combined with Looping Array

Sub CountUniqueCollectionArray()
    Dim Ws As Worksheet
    Dim Col As New Collection
    Dim Cell As Range, Rng As Range
    Dim UniqueCount As Long, i As Long
    Dim Arr
    Set Ws = Worksheets("100")
    Set Rng = Ws.Range("A2:A" & Ws.Range("A" & Rows.Count).End(xlUp).Row)
    Arr = Rng
    For i = LBound(Arr) To UBound(Arr)
        On Error Resume Next
        Col.Add Arr(i, 1), Key:=Arr(i, 1)
    Next i
    UniqueCount = Col.Count
    Debug.Print UniqueCount
End Sub

Results

Approach 10 – Dictionary – Late Binding combined with Looping Array

Sub CountUniqueDictArray()
    Dim Ws As Worksheet
    Dim Dict As Object
    Dim Rng As Range
    Dim Arr
    Dim UniqueCount As Long, i As Long
    Set Dict = CreateObject("Scripting.Dictionary")
    Set Ws = Worksheets("100")
    Set Rng = Ws.Range("A2:A" & Ws.Range("A" & Rows.Count).End(xlUp).Row)
    Arr = Rng
    For i = LBound(Arr) To UBound(Arr)
       Dict(Arr(i, 1)) = Arr(i, 1)
    Next i
    UniqueCount = Dict.Count
    Debug.Print UniqueCount
End Sub

 Results

Approach 11 – Dictionary – Early Binding combined with Looping Array

Sub CountUniqueDictEBArray()
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim UniqueCount As Long, i As Long
    Dim Arr
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Set Ws = Worksheets("100")
    Set Rng = Ws.Range("A2:A" & Ws.Range("A" & Rows.Count).End(xlUp).Row)
    Arr = Rng
    For i = LBound(Arr) To UBound(Arr)
       Dict(Arr(i, 1)) = Arr(i, 1)
    Next i
    UniqueCount = Dict.Count
    Debug.Print UniqueCount
End Sub

 Results

FINAL RESULTS

Below is the final results tabulated. Dictionary – Early Binding – Looping Array wins in all approaches.

But Early Binding demands that Microsoft Scripting Library should be added to VBA References and if you are working in Multi user environment, then it may not be possible.  In this case, the best approach is Dictionary – Late Binding – Looping Array whereas Collections Looping Array approach is best for smaller records like <1000.