You could make it about 6-7 times faster still by using cSortedDictionary,
which you can download from here:
http://www.thecommon.net/9.html
Option Explicit
Private lStartTime As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Public Function COUNTU(theRange As Range) As Variant
Dim r As Long
Dim c As Long
Dim colUniques As Collection
Dim cSD As cSortedDictionary
Dim vArr As Variant
Dim vCell As Variant
Dim vLcell As Variant
Dim oRng As Range
Dim bCSD As Boolean
Set colUniques = New Collection
Set cSD = New cSortedDictionary
Set oRng = Intersect(theRange, theRange.Parent.UsedRange)
vArr = oRng
bCSD = True
On Error Resume Next
If bCSD Then
For Each vCell In vArr
If vCell <> vLcell Then
If Len(vCell) > 0 Then
cSD.Add vCell
End If
End If
vLcell = vCell
Next vCell
Else
For Each vCell In vArr
If vCell <> vLcell Then
If Len(vCell) > 0 Then
colUniques.Add vCell, CStr(vCell)
End If
End If
vLcell = vCell
Next vCell
End If
If bCSD Then
COUNTU = cSD.Count
Else
COUNTU = colUniques.Count
End If
End Function
Sub test()
Dim lUnique As Long
StartSW
lUnique = COUNTU(Range(Cells(1), Cells(65536, 1)))
StopSW
MsgBox lUnique
End Sub
Sub StartSW()
lStartTime = timeGetTime()
End Sub
Function StopSW(Optional bMsgBox As Boolean = True, _
Optional vMessage As Variant, _
Optional lMinimumTimeToShow As Long = -1) As Variant
Dim lTime As Long
lTime = timeGetTime() - lStartTime
If lTime > lMinimumTimeToShow Then
If IsMissing(vMessage) Then
StopSW = lTime
Else
StopSW = lTime & " - " & vMessage
End If
End If
If bMsgBox Then
If lTime > lMinimumTimeToShow Then
MsgBox "Done in " & lTime & " msecs", , vMessage
End If
End If
End Function
Also, you may want to leave this out:
If vCell <> vLcell Then
If Len(vCell) > 0 Then
Haven't tested with the regular dictionary object.
RBS
