Fadi,
The code may come from JWalk but is painfully slow
It takes 14 seconds on an array of 1000 elements..
dont think of running it on 2000 or more.
Following will work effortless with large arrays, and returns
5000 sorted uniques from 60000 text set in under .5 seconds.
Option Explicit
Option Compare Text
Public Function Uniques(ByVal vSourceArray As Variant, _
Optional ByVal Sorted As Byte, _
Optional ByVal CountOnly As Boolean)
'author:keepITcool
'Requires Ref to Microsoft Scripting Runtime
Dim oDic As Dictionary
Dim n&, l&, v, itm
'Initialize the dictionary
Set oDic = New Dictionary
oDic.CompareMode = TextCompare
'Exit if no array
If Not IsArray(vSourceArray) Then GoTo theExit
'Take values if Range
If TypeName(vSourceArray) = "Range" Then vSourceArray = vSourceArray
'Key must be unique, so doubles give (ignored) errors
On Error Resume Next
For Each itm In vSourceArray
oDic.Add itm, itm
Next
'Quicker then testing for empties, just remove it
oDic.Remove vbNullString
On Error GoTo theError
If CountOnly Then
v = oDic.Count
Else
v = oDic.Items
'make 1based for compatibility
ReDim Preserve v(1 To UBound(v) - LBound(v) + 1)
Select Case Sorted
Case Is 0: Call QSort(v, xlAscending)
Case Is < 0: Call QSort(v, xlDescending)
End Select
End If
theExit:
Uniques = v
Exit Function
theError:
Uniques = CVErr(xlErrValue)
End Function
Public Sub QSort(v, _
Optional SortOrder As XlSortOrder = xlAscending, _
Optional n& = True, Optional m& = True)
Dim i&, j&, p, t
If n = True Then n = LBound(v)
If m = True Then m = UBound(v)
i = n: j = m: p = v((n + m) \ 2)
While (i <= j)
While (v(i) < p And i < m): i = i + 1: Wend
While (v(j) p And j n): j = j - 1: Wend
If (i <= j) Then
t = v(i): v(i) = v(j): v(j) = t
i = i + 1: j = j - 1
End If
Wend
If (n < j) Then QSort v, SortOrder, n, j
If (i < m) Then QSort v, SortOrder, i, m
End Sub
--
keepITcool
|
www.XLsupport.com | keepITcool chello nl | amsterdam
Fadi Chalouhi wrote :
Hi Chris,
You can create a UDF (IUser-Defined Function) to generate this list
for you. Check this post :
http://www.chalouhis.com/XLBLOG/arch.../unique-cells/
HTH
Fadi