Function to count distinct values in a column range

Question

I am attempting to create a function in VBA that, when given a range of values, will return a Count Distinct of those values. For example:

| Column A | |-----

Answer 1

Sub CountDistinct()
    Dim RunSub As Long
    Dim LastRow As Long
    Dim CurRow As Long
    Dim Unique As Long

        LastRow = Range("A" & Rows.Count).End(xlUp).Row
        Unique = 1

        For CurRow = 2 To LastRow
            If Range("A2:A" & CurRow - 1).Find(Range("A" & CurRow, LookIn:=xlValues)) Is Nothing Then
            Unique = Unique + 1
            Else
            End If
        Next CurRow

        MsgBox Unique & " Unique Values"

End Sub

Answer 2

In Excel 2013, use Distinct Count in a PivotTable.

Answer 3

There are (of course) other ways this could be done with VBA.

Public Function CountDistinct(rng As Range) As Long
  Dim i As Long
  Dim Cnt As Double
  Cnt = 0
  For i = 1 To rng.Rows.Count
    Cnt = Cnt + 1 / WorksheetFunction.CountIf(rng, rng(i, 1))
  Next i
  CountDistinct = CLng(Cnt)
End Function

Answer 4

Way late to the party, but I thought I would put in another VBA option that does not require adding a reference.

In addition this touches on a neat function of excel VBA that I wish I had learn much earlier.

My solution to this uses the Collection object in order to find distinct values.

Option Explicit
'^ As SeanC said, adding Option Explicit is a great way to prevent writing errors when starting out.
Public Function CountDistinct(r As Range) As Long
'' DIM = declare in memory

Dim col As Collection
Dim arr As Variant
Dim x As Long
Dim y As Long

Set col = New Collection
'' setting a Variant = Range will fill the Variant with a 2 dimensional array of the values of the range!
arr = r
'' skip the errors that are raised
On Error Resume Next
'' loop over all of the elements.
'' UBound is a built in VBA Function that gives you the largest value of an array.
    For x = 1 To UBound(arr, 1)
        For y = 1 To UBound(arr, 2)
            '' try to add the value in arr to the collection
            col.Add 0, CStr(arr(x, y))

            '' every time the collection runs into a value it has already added,
            '' it will raise an error.
            'uncomment the below to see why we are turning off errors
            'Debug.Print Err.Number, Err.Description

        Next
    Next
'' turn errors back on.
On Error GoTo 0
''set the function name to the value you want the formula to return
CountDistinct = col.Count
'' The next parts should be handled by VBA automatically but it is good practise to explicitly clean up.
Set col = Nothing
Set arr = Nothing
Set r = Nothing
End Function

I hope this helps someone down the line.

Answer 5

First Steps:
Add Option Explicit to the header of all your modules. It will capture the difference between OneVariable and OneVarlable.
Make your variables meaningful - will you know what x and i were for next time you look at this code?

Your options for the count are

1. user the worksheet function
2. save the values, and only count those that don't match previous values

Using the worksheet function,

Option Explicit

Function CountUnique(dataRange As Range) As Long
Dim CheckCell
Dim Counter As Double
Counter = 0

For Each CheckCell In dataRange.Cells
    Counter = Counter + (1 / (WorksheetFunction.CountIf(dataRange, CheckCell.Value)))
Next
' Finally, set your function name equal to the Counter, 
'   so it knows what to return to Excel
CountUnique = Counter
End Function

Using the keeping track

...
' check out scripting dictionaries
' much more advanced - Keep it simple for now
...

Answer 6

This method applies the following logic.

• Place the range elements into an array
• Place the array into a dictionary for unique elements only
• Count the elements (keys) in the dictionary for unique elements

Under Tools-->References, Reference "Microsoft Scripting Runtime"

Option Explicit

Dim lngCounter As Long
Dim dataRange As Range
Dim dictTemp As Dictionary
Dim varTemp As Variant

Sub Test()

Set dataRange = Range(Cells(2, 1), Cells(12, 1))

MsgBox CountDistinct(dataRange), vbInformation + vbSystemModal, "Count Distinct"

End Sub

Public Function CountDistinct(dataRange As Range) As Long

'Populate range into array
If dataRange.Rows.Count < 2 Then
    ReDim varTemp(1 To 1, 1 To 1)
    varTemp(1, 1) = dataRange
Else
    varTemp = dataRange
End If

'Dictionaries can be used to store unique keys into memory
Set dictTemp = New Dictionary

'Add array items into dictionary if they do not exist
For lngCounter = LBound(varTemp) To UBound(varTemp)
    If dictTemp.Exists(varTemp(lngCounter, 1)) = False Then
        dictTemp.Add Key:=varTemp(lngCounter, 1), Item:=1
    End If
Next lngCounter

'Count of unique items in dictionary
CountDistinct = dictTemp.Count

End Function