Excel VBA - Counting Unique Cells in a Range

[wuming]

To count unique values in a column in a range we can use:

=SUMPRODUCT((Table!D21000<>"")/(COUNTIF(Table!D21000,Table!D21000)+(Table!D21000="")))

That is if the data range is around 1k+ but what if i want to coun
lets say 60k records?? i tried using the above function to count 10
records and it hangs. Does anyone have solution to count up to 60
records?

 

[macropod]

Give the following a try. I didn't write it, so it'll probably work

Cheers

Sub ExtractUniqueList()
Dim wksList As Worksheet
Dim rngList As Range, rngDest As Range
Dim iSortOrder As Integer
'********Change as appropriate ***************
'1=Ascending, 0 = unsorted, -1 = Descending
iSortOrder = iorder
Set rngDest = Worksheets("Sheet1").Range("D1")
Set wksList = Worksheets("Sheet1")
With wksList
Set rngList = .Range(.Range("A1"), .Range("a65536").End(xlUp))
End With
'*********************************************************
Call ExtractList(UniqueList(rngList.Value, iSortOrder), rngDest)
Set rngDest = Nothing
Set rngList = Nothing
Set wksList = Nothing
End Sub

Sub ExtractList(vArray, rng As Range)
Dim vExtract()
Dim x As Long, lItems As Long
lItems = UBound(vArray)
ReDim vExtract(1 To lItems, 1 To 1)
For x = 1 To lItems
vExtract(x, 1) = vArray(x)
Next
With rng
.Resize(65537 - .Row, 1).ClearContents
.Resize(lItems, 1).Value = vExtract
End With
End Sub

Public Function UniqueList(vArray, Optional iorder As Integer = 1)
'Takes an array and gives a unique list as an array output
'iOrder determines the sort at the end:
' 1 = Ascending (Default)
' 0 = Unsorted
' -1 = Descending
Dim lItems As Long
Dim NoDupes As New Collection
Dim x As Integer, y As Integer, i As Integer, j As Integer
Dim Temp1, Temp2, vTemp()
On Error Resume Next
For lItems = LBound(vArray) To UBound(vArray)
If Not (IsEmpty(vArray(lItems, 1))) Then
If vArray(lItems, 1) <> "" Then _
NoDupes.Add vArray(lItems, 1), CStr(vArray(lItems, 1))
End If
Next lItems
On Error GoTo 0
lItems = NoDupes.Count
If iorder <> 0 Then
For x = 1 To lItems - 1
For y = x + 1 To lItems
i = IIf(iorder < 0, y, x)
j = IIf(iorder < 0, x, y)
If NoDupes(i) > NoDupes(j) Then
Temp1 = NoDupes(i)
Temp2 = NoDupes(j)
NoDupes.Add Temp1, before:=j
NoDupes.Add Temp2, before:=i
NoDupes.Remove x + 1
NoDupes.Remove y + 1
End If
Next y
Next x
End If
ReDim vTemp(1 To lItems)
For x = 1 To lItems
vTemp(x) = NoDupes(x)
Next x
UniqueList = vTemp
End Function

 

[wuming]

thats a lot of coding over there! i am a new user to excel vba and i du
think i can digest it immediately, however i would try to use the cod
if it works!
Thanks btw macropod! :