You could make it about 6-7 times faster still by using cSortedDictionary,
which you can download from he
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


"Bernd P" wrote in message
...
Hello,

I suggest to use Charles Williams' UDF countu:

http://msdn.microsoft.com/en-us/library/aa730921.aspx

Regards,
Bernd