数组排序函数 VBA? ？

小开

最佳答案

~~Take a look here:~~
Edit: The referenced source (allexperts.com) has since closed, but here are the relevant author comments:

There are many algorithms available on the web for sorting. The most versatile and usually the quickest is the Quicksort algorithm. Below is a function for it.

Call it simply by passing an array of values (string or numeric; it doesn't matter) with the Lower Array Boundary (usually 0) and the Upper Array Boundary (i.e. UBound(myArray).)

Example: Call QuickSort(myArray, 0, UBound(myArray))

When it's done, myArray will be sorted and you can do what you want with it.
_{(Source: archive.org)}

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot   As Variant
Dim tmpSwap As Variant
Dim tmpLow  As Long
Dim tmpHi   As Long


tmpLow = inLow
tmpHi = inHi


pivot = vArray((inLow + inHi) \ 2)


While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend


While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend


If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend


If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Note that this only works with single-dimensional (aka "normal"?) arrays. (There's a working multi-dimensional array QuickSort here.)

小开

Explanation in German but the code is a well-tested in-place implementation:

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
Dim P1 As Long, P2 As Long, Ref As String, TEMP As String


P1 = LB
P2 = UB
Ref = Field((P1 + P2) / 2)


Do
Do While (Field(P1) < Ref)
P1 = P1 + 1
Loop


Do While (Field(P2) > Ref)
P2 = P2 - 1
Loop


If P1 <= P2 Then
TEMP = Field(P1)
Field(P1) = Field(P2)
Field(P2) = TEMP


P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)


If LB < P2 Then Call QuickSort(Field, LB, P2)
If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub

Invoked like this:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

小开

I converted the 'fast quick sort' algorithm to VBA, if anyone else wants it.

I have it optimized to run on an array of Int/Longs but it should be simple to convert it to one that works on arbitrary comparable elements.

Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
Dim M As Long, i As Long, j As Long, v As Long
M = 4


If ((r - l) > M) Then
i = (r + l) / 2
If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
If (a(l) > a(r)) Then swap a, l, r
If (a(i) > a(r)) Then swap a, i, r


j = r - 1
swap a, i, j
i = l
v = a(j)
Do
Do: i = i + 1: Loop While (a(i) < v)
Do: j = j - 1: Loop While (a(j) > v)
If (j < i) Then Exit Do
swap a, i, j
Loop
swap a, i, r - 1
QuickSort a, l, j
QuickSort a, i + 1, r
End If
End Sub


Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
Dim T As Long
T = a(i)
a(i) = a(j)
a(j) = T
End Sub


Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
Dim i As Long, j As Long, v As Long


For i = lo0 + 1 To hi0
v = a(i)
j = i
Do While j > lo0
If Not a(j - 1) > v Then Exit Do
a(j) = a(j - 1)
j = j - 1
Loop
a(j) = v
Next i
End Sub


Public Sub sort(ByRef a() As Long)
QuickSort a, LBound(a), UBound(a)
InsertionSort a, LBound(a), UBound(a)
End Sub

小开

I posted some code in answer to a related question on StackOverflow:

Sorting a multidimensionnal array in VBA

The code samples in that thread include:

A vector array Quicksort;
A multi-column array QuickSort;
A BubbleSort.

Alain's optimised Quicksort is very shiny: I just did a basic split-and-recurse, but the code sample above has a 'gating' function that cuts down on redundant comparisons of duplicated values. On the other hand, I code for Excel, and there's a bit more in the way of defensive coding - be warned, you'll need it if your array contains the pernicious 'Empty()' variant, which will break your While... Wend comparison operators and trap your code in an infinite loop.

Note that quicksort algorthms - and any recursive algorithm - can fill the stack and crash Excel. If your array has fewer than 1024 members, I'd use a rudimentary BubbleSort.

Public Sub QuickSortArray(ByRef SortArray As Variant, _
Optional lngMin As Long = -1, _
Optional lngMax As Long = -1, _
Optional lngColumn As Long = 0)
On Error Resume Next

'Sort a 2-Dimensional array

' Sample Usage: sort arrData by the contents of column 3
'
'   QuickSortArray arrData, , , 3

'
'Posted by Jim Rech 10/20/98 Excel.Programming

'Modifications, Nigel Heffernan:

'       ' Escape failed comparison with empty variant
'       ' Defensive coding: check inputs

Dim i           As Long
Dim j           As Long
Dim varMid      As Variant
Dim arrRowTemp  As Variant
Dim lngColTemp  As Long


If IsEmpty(SortArray) Then
Exit Sub
End If

If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken:  Look for brackets in the type name
Exit Sub
End If

If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If

If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If

If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If


i = lngMin
j = lngMax

varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

' We  send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid might pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf varType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf varType(varMid) > 17 Then
i = lngMax
J=lngmin
End If


While i <= j

While SortArray(i, lngColumn) < varMid And i < lngMax
i = i + 1
Wend

While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend


If i <= j Then

' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp

i = i + 1
j = j - 1

End If


Wend

If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)


End Sub

小开

You didn't want an Excel-based solution but since I had the same problem today and wanted to test using other Office Applications functions I wrote the function below.

Limitations:

2-dimensional arrays;
maximum of 3 columns as sort keys;
depends on Excel;

Tested calling Excel 2010 from Visio 2010

Option Base 1




Private Function sort_array_2D_excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")


'   Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library


Dim excel_application As Excel.Application
Dim excel_workbook As Excel.Workbook
Dim excel_worksheet As Excel.Worksheet


Set excel_application = CreateObject("Excel.Application")


excel_application.Visible = True
excel_application.ScreenUpdating = False
excel_application.WindowState = xlNormal


Set excel_workbook = excel_application.Workbooks.Add
excel_workbook.Activate


Set excel_worksheet = excel_workbook.Worksheets.Add
excel_worksheet.Activate
excel_worksheet.Visible = xlSheetVisible


Dim excel_range As Excel.Range
Set excel_range = excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
excel_range = array_2D




For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)


If IsNumeric(array_sortkeys(i_sortkey)) Then
sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
Set array_sortkeys(i_sortkey) = excel_worksheet.Range(sortkey_range)


Else
MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
End


End If


Next i_sortkey




For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
Select Case LCase(array_sortorders(i_sortorder))
Case "asc"
array_sortorders(i_sortorder) = XlSortOrder.xlAscending
Case "desc"
array_sortorders(i_sortorder) = XlSortOrder.xlDescending
Case Else
array_sortorders(i_sortorder) = XlSortOrder.xlAscending
End Select
Next i_sortorder


Select Case LCase(tag_header)
Case "yes"
tag_header = Excel.xlYes
Case "no"
tag_header = Excel.xlNo
Case "guess"
tag_header = Excel.xlGuess
Case Else
tag_header = Excel.xlGuess
End Select


Select Case LCase(tag_matchcase)
Case "true"
tag_matchcase = True
Case "false"
tag_matchcase = False
Case Else
tag_matchcase = False
End Select




Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
Case 1
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
Case 2
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
Case 3
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
Case Else
MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
End
End Select




For i_row = 1 To excel_range.Rows.Count


For i_column = 1 To excel_range.Columns.Count


array_2D(i_row, i_column) = excel_range(i_row, i_column)


Next i_column


Next i_row




excel_workbook.Close False
excel_application.Quit


Set excel_worksheet = Nothing
Set excel_workbook = Nothing
Set excel_application = Nothing




sort_array_2D_excel = array_2D




End Function

This is an example on how to test the function:

Private Sub test_sort()


array_unsorted = dim_sort_array()


Call msgbox_array(array_unsorted)


array_sorted = sort_array_2D_excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")


Call msgbox_array(array_sorted)


End Sub




Private Function dim_sort_array()


Dim array_unsorted(1 To 5, 1 To 3) As String


i_row = 0


i_row = i_row + 1
array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"


i_row = i_row + 1
array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)


i_row = i_row + 1
array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)


i_row = i_row + 1
array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)


i_row = i_row + 1
array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)


dim_sort_array = array_unsorted


End Function




Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")


msgbox_string = string_info & vbLf


For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)


msgbox_string = msgbox_string & vbLf & i_row & vbTab


For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)


msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab


Next i_column


Next i_row


MsgBox msgbox_string


End Sub

If anybody tests this using other versions of office please post here if there are any problems.

小开

Natural Number (Strings) Quick Sort

Just to pile onto the topic. Normally, if you sort strings with numbers you'll get something like this:

    Text1
Text10
Text100
Text11
Text2
Text20

But you really want it to recognize the numerical values and be sorted like

    Text1
Text2
Text10
Text11
Text20
Text100

Here's how to do it...

Note:

I stole the Quick Sort from the internet a long time ago, not sure where now...
I translated the CompareNaturalNum function which was originally written in C from the internet as well.
Difference from other Q-Sorts: I don't swap the values if the BottomTemp = TopTemp

Natural Number Quick Sort

Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer


intBottomTemp = intBottom
intTopTemp = intTop


strPivot = strArray((intBottom + intTop) \ 2)


Do While (intBottomTemp <= intTopTemp)
' < comparison of the values is a descending sort
Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
intBottomTemp = intBottomTemp + 1
Loop
Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
intTopTemp = intTopTemp - 1
Loop
If intBottomTemp < intTopTemp Then
strTemp = strArray(intBottomTemp)
strArray(intBottomTemp) = strArray(intTopTemp)
strArray(intTopTemp) = strTemp
End If
If intBottomTemp <= intTopTemp Then
intBottomTemp = intBottomTemp + 1
intTopTemp = intTopTemp - 1
End If
Loop


'the function calls itself until everything is in good order
If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub

Natural Number Compare(Used in Quick Sort)

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer


If Not (IsNull(string1) Or IsNull(string2)) Then
iPos1 = 1
iPos2 = 1
Do While iPos1 <= Len(string1)
If iPos2 > Len(string2) Then
CompareNaturalNum = 1
Exit Function
End If
If isDigit(string1, iPos1) Then
If Not isDigit(string2, iPos2) Then
CompareNaturalNum = -1
Exit Function
End If
iPosOrig1 = iPos1
iPosOrig2 = iPos2
Do While isDigit(string1, iPos1)
iPos1 = iPos1 + 1
Loop


Do While isDigit(string2, iPos2)
iPos2 = iPos2 + 1
Loop


nOffset1 = (iPos1 - iPosOrig1)
nOffset2 = (iPos2 - iPosOrig2)


n1 = Val(Mid(string1, iPosOrig1, nOffset1))
n2 = Val(Mid(string2, iPosOrig2, nOffset2))


If (n1 < n2) Then
CompareNaturalNum = -1
Exit Function
ElseIf (n1 > n2) Then
CompareNaturalNum = 1
Exit Function
End If


' front padded zeros (put 01 before 1)
If (n1 = n2) Then
If (nOffset1 > nOffset2) Then
CompareNaturalNum = -1
Exit Function
ElseIf (nOffset1 < nOffset2) Then
CompareNaturalNum = 1
Exit Function
End If
End If
ElseIf isDigit(string2, iPos2) Then
CompareNaturalNum = 1
Exit Function
Else
If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
CompareNaturalNum = -1
Exit Function
ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
CompareNaturalNum = 1
Exit Function
End If


iPos1 = iPos1 + 1
iPos2 = iPos2 + 1
End If
Loop
' Everything was the same so far, check if Len(string2) > Len(String1)
' If so, then string1 < string2
If Len(string2) > Len(string1) Then
CompareNaturalNum = -1
Exit Function
End If
Else
If IsNull(string1) And Not IsNull(string2) Then
CompareNaturalNum = -1
Exit Function
ElseIf IsNull(string1) And IsNull(string2) Then
CompareNaturalNum = 0
Exit Function
ElseIf Not IsNull(string1) And IsNull(string2) Then
CompareNaturalNum = 1
Exit Function
End If
End If
End Function

isDigit(Used in CompareNaturalNum)

Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
If pos <= Len(str) Then
iCode = Asc(Mid(str, pos, 1))
If iCode >= 48 And iCode <= 57 Then isDigit = True
End If
End Function

小开

I wonder what would you say about this array sorting code. It's quick for implementation and does the job ... haven't tested for large arrays yet. It works for one-dimensional arrays, for multidimensional additional values re-location matrix would need to be build (with one less dimension that the initial array).

       For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
eValue = eArray(AR1)
For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
If eArray(AR2) < eValue Then
eArray(AR1) = eArray(AR2)
eArray(AR2) = eValue
eValue = eArray(AR1)
End If
Next AR2
Next AR1

小开

This is what I use to sort in memory - it can easily be expanded to sort an array.

Sub sortlist()


Dim xarr As Variant
Dim yarr As Variant
Dim zarr As Variant


xarr = Sheets("sheet").Range("sing col range")
ReDim yarr(1 To UBound(xarr), 1 To 1)
ReDim zarr(1 To UBound(xarr), 1 To 1)


For n = 1 To UBound(xarr)
zarr(n, 1) = 1
Next n


For n = 1 To UBound(xarr) - 1
y = zarr(n, 1)
For a = n + 1 To UBound(xarr)
If xarr(n, 1) > xarr(a, 1) Then
y = y + 1
Else
zarr(a, 1) = zarr(a, 1) + 1
End If
Next a
yarr(y, 1) = xarr(n, 1)
Next n


y = zarr(UBound(xarr), 1)
yarr(y, 1) = xarr(UBound(xarr), 1)


yrng = "A1:A" & UBound(yarr)
Sheets("sheet").Range(yrng) = yarr


End Sub

小开

I think my code (tested) is more "educated", assuming the simpler the better.

Option Base 1


'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
Dim check As Boolean
check = True
If IsNull(Rango) Then
check = False
End If
If check Then
Application.Volatile
Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
ReDim x(n, m)
For i = 1 To n Step 1
For j = 1 To m Step 1
x(i, j) = Application.Large(Rango, k)
k = k - 1
Next j
Next i
SORT = x
Else
Exit Function
End If
End Function

小开

Dim arr As Object
Dim InputArray


'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")


'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")


'number
'InputArray = Array(6, 5, 3, 4, 2, 1)


' adding the elements in the array to array_list
For Each element In InputArray
arr.Add element
Next


'sorting happens
arr.Sort


'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.


sorted_array = arr.toarray

小开

Heapsort implementation. An O(n log(n)) (both average and worst case), in place, unstable sorting algorithm.

Use with: Call HeapSort(A), where A is a one dimensional array of variants, with Option Base 1.

Sub SiftUp(A() As Variant, I As Long)
Dim K As Long, P As Long, S As Variant
K = I
While K > 1
P = K \ 2
If A(K) > A(P) Then
S = A(P): A(P) = A(K): A(K) = S
K = P
Else
Exit Sub
End If
Wend
End Sub


Sub SiftDown(A() As Variant, I As Long)
Dim K As Long, L As Long, S As Variant
K = 1
Do
L = K + K
If L > I Then Exit Sub
If L + 1 <= I Then
If A(L + 1) > A(L) Then L = L + 1
End If
If A(K) < A(L) Then
S = A(K): A(K) = A(L): A(L) = S
K = L
Else
Exit Sub
End If
Loop
End Sub


Sub HeapSort(A() As Variant)
Dim N As Long, I As Long, S As Variant
N = UBound(A)
For I = 2 To N
Call SiftUp(A, I)
Next I
For I = N To 2 Step -1
S = A(I): A(I) = A(1): A(1) = S
Call SiftDown(A, I - 1)
Next
End Sub

小开

@Prasand Kumar, here's a complete sort routine based on Prasand's concepts:

Public Sub ArrayListSort(ByRef SortArray As Variant)
'
'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
'data-type.
'
'AUTHOR: Peter Straton
'
'CREDIT: Derived from Prasand Kumar's post at: https://stackoverflow.com/questions/152319/vba-array-sort-function
'
'*************************************************************************************************************


Static ArrayListObj As Object
Dim i As Long
Dim LBnd As Long
Dim UBnd As Long


LBnd = LBound(SortArray)
UBnd = UBound(SortArray)


'If necessary, create the ArrayList object, to be used to sort the specified array's values


If ArrayListObj Is Nothing Then
Set ArrayListObj = CreateObject("System.Collections.ArrayList")
Else
ArrayListObj.Clear  'Already allocated so just clear any old contents
End If


'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
'using a single assignment statement.)


For i = LBnd To UBnd
ArrayListObj.Add SortArray(i)
Next i


ArrayListObj.Sort   'Do the sort


'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
'statement.  But the result is always zero-based so then, if necessary, adjust the resulting array to match
'its original index base.


SortArray = ArrayListObj.ToArray
If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub

小开

Somewhat related, but I was also looking for a native excel VBA solution since advanced data structures (Dictionaries, etc.) aren't working in my environment. The following implements sorting via a binary tree in VBA:

Assumes array is populated one by one
Removes duplicates
Returns a separated string ("0|2|3|4|9") which can then be split.

I used it for returning a raw sorted enumeration of rows selected for an arbitrarily selected range

Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
If CenterType = tEMPTY Then
Center = x
CenterType = tValue
ElseIf x > Center Then
If RightType = tEMPTY Then
Right = x
RightType = tValue
ElseIf RightType = tTree Then
Right.Add x
ElseIf x <> Right Then
curLeaf = Right
Set Right = New TreeList
Right.Add curLeaf
Right.Add x
RightType = tTree
End If
ElseIf x < Center Then
If LeftType = tEMPTY Then
Left = x
LeftType = tValue
ElseIf LeftType = tTree Then
Left.Add x
ElseIf x <> Left Then
curLeaf = Left
Set Left = New TreeList
Left.Add curLeaf
Left.Add x
LeftType = tTree
End If
End If
End Sub
Public Function GetList$()
Const sep$ = "|"
If LeftType = tValue Then
LeftList$ = Left & sep
ElseIf LeftType = tTree Then
LeftList = Left.GetList & sep
End If
If RightType = tValue Then
RightList$ = sep & Right
ElseIf RightType = tTree Then
RightList = sep & Right.GetList
End If
GetList = LeftList & Center & RightList
End Function


'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")