Count (Not list!) unique items in a range to assign to a variable

Question

I need a count of unique items from a range to know how many lines to add to make room for a pivot table. Being that I know excel better then VBA I put together the following code:

    With ActiveSheet
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    Range("F" & LR).Formula2R1C1 = "=UNIQUE(R3C:R[-1]C)"
    
    With ActiveSheet
        CT = .Cells(.Rows.Count, "F").End(xlUp).Row
    End With
    
    Range("F" & LR).ClearContents
    
    R = "1:" & CT - LR + 3
    Rows(R).Insert Shift:=xlDown

I would like to know how I can have VBA do the calulations on its own so I can avoid adding and deleting formulas from the sheet.

Answer 1

You can count Unique in VBA by adding to a collection or taken your post as an example by using the UNIQUE function in combination with evaluate:

With ActiveSheet
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
    x = UBound(Application.Evaluate("UNIQUE(F3:F" & LR & ")"))

Answer 2

Count Unique (Dictionary)

• If you don't have 365 ie you don't have UNIQUE you can use the following function.

The Function and OP's Test

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the number of unique values in a range.
' Remarks:      Error and empty values are excluded.
'               The range can be non-contiguous.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function countUnique(SourceRange As Range) _
         As Long
    
    ' Initialize error handling.
    Const ProcName As String = "countUnique"
    On Error GoTo clearError ' Turn on error trapping.

    ' Check Source Range.
    If SourceRange Is Nothing Then
        GoTo ProcExit
    End If
    
    ' Write values from Source Range to arrays of Data Array ('Data').
    Dim AreasCount As Long
    AreasCount = SourceRange.Areas.Count
    Dim Help As Variant
    ReDim Help(1 To 1, 1 To 1)
    Dim Data As Variant
    ReDim Data(1 To AreasCount)
    Dim rng As Range
    Dim n As Long
    For Each rng In SourceRange.Areas
        n = n + 1
        If rng.Rows.Count > 1 Or rng.Columns.Count > 1 Then
            Data(n) = rng.Value
        Else
            Data(n) = Help
            Data(1, 1) = rng.Value
        End If
    Next rng
    
    ' Write (unique) values from arrays of Data Array to a Dictionary ('dict').
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim CurrentValue As Variant
    Dim i As Long
    Dim j As Long
    For n = 1 To AreasCount
        For i = 1 To UBound(Data(n), 1)
            For j = 1 To UBound(Data(n), 2)
                CurrentValue = Data(n)(i, j)
                If Not IsError(CurrentValue) And Not IsEmpty(CurrentValue) Then
                    dict(CurrentValue) = Empty
                End If
            Next j
        Next i
    Next n
                
    ' Write result (number of elements in the Dictionary).
    countUnique = dict.Count

ProcExit:
    Exit Function

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

End Function

Sub testOP()
    Dim LR As Long ' Last Row
    Dim UC As Long ' Unique Count
    With ActiveSheet
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
        UC = countUnique(.Range(.Cells(3, "F"), .Cells(LR, "F")))
        Debug.Print UC
    End With
End Sub

Non-Contiguous Test

' Select a range. Then press CTRL and select another range, etc.
' Then run the following procedure.
Sub testNonContiguous()
    Dim rng As Range
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        MsgBox "Range '" & rng.Address(0, 0) & "' contains " _
              & countUnique(rng) & " unique item(s)."
    End If
End Sub

Performance Tests

' Copy the following formula to A1 and copy down to the bottom of the worksheet.
' =RANDBETWEEN(1,1000000)
' Select the whole column and do a 'Copy/Paste Values'.

' Running this test took about 21 seconds on my machine.
Sub testCountUnique()
    Dim rng As Range
    Set rng = Range("A:A")
    Debug.Print "Range '" & rng.Address(0, 0) & "' contains " _
              & countUnique(rng) & " unique item(s)."
End Sub

' This is the same test using UNIQUE which I don't have. I would appreciate
' the feedback, if someone could measure the time this takes to finish.
Sub testUnique()
    Dim rng As Range
    Set rng = Range("A:A")
    Debug.Print "Range '" & rng.Address(0, 0) & "' contains " _
              & UBound(Application.Evaluate("UNIQUE(" _
              & rng.Address(0, 0) & ")")) & " unique item(s)."
End Sub

Answer 3

You can try so:

Function getCountUnique(rSource As Range) As Long
    With Application.WorksheetFunction
        getCountUnique = .Count(.Unique(rSource, False, False))
    End With
End Function

Call it from your subroutine like as:

With ActiveSheet
    LR = ActiveSheet.Cells(.Rows.Count, "A").End(xlUp).Row
    uniCount = getCountUnique(.Range("A3:A" & LR))
End With