Amazingly (or maybe not) the second posted method is only very
slightly faster than the first.

RBS


On 12 Sep, 14:29, "RB Smissaert"
wrote:
Here an array sort I found somewhere that allows sorting on multiple
columns:

Option Explicit
Option Compare Binary

Sub test()

* Dim arr

* arr = Range(Cells(1), Cells(6, 3))

* Sort2D arr, False, 1, 0, 0, 2, 1, 0, 3, 1, 0

* Range(Cells(5), Cells(6, 7)) = arr

End Sub

Function Sort2D(vArray As Variant, _
* * * * * * * * bHorizontal As Boolean, _
* * * * * * * * ParamArray SortIndex() As Variant)

* 'Explanation of arguments
* '-------------------------
* 'you need to specify the paramarray arguments in groups of three being for
* 'the column or row to sort by, then whether ascending or descending, then
* 'whether textual or binary sort. repeat the param array arguements for as
* 'many columns you want to sort in the appropiate order. *eg. to sort a 2D
* 'array by column 1 descending binary, then by column 3 descending textual,
* 'then by column 5 *ascending binary use the following syntax:
* 'Sort2D A(),False, 1, 0, 0, 3, 0 , 1, 5 , 1, 0
* '--------------------------------------------------------------------------

* Dim i As Long
* Dim j As Long
* Dim k As Long
* Dim m As Long
* Dim n As Long
* Dim z As Long
* Dim lb1 As Long
* Dim lb2 As Long
* Dim ub1 As Long
* Dim ub2 As Long
* Dim D
* Dim sIdx() As Long
* Dim dsnd() As Boolean
* Dim stype() As Boolean

* lb1 = LBound(vArray, 1)
* lb2 = LBound(vArray, 2)
* ub1 = UBound(vArray, 1)
* ub2 = UBound(vArray, 2)

* D = vArray

* If UBound(SortIndex) < 0 Then
* * ReDim sIdx(0 To 0) As Long
* * ReDim dsnd(0 To 0) As Boolean
* * ReDim stype(0 To 0) As Boolean
* * sIdx(0) = 1
* * dsnd(0) = True
* * stype(0) = True
* Else
* * ReDim sIdx(0 To UBound(SortIndex) \ 3)
* * ReDim dsnd(0 To UBound(SortIndex) \ 3)
* * ReDim stype(0 To UBound(SortIndex) \ 3)
* * For i = 0 To UBound(SortIndex) \ 3
* * * sIdx(i) = CLng(SortIndex(i * 3))
* * * dsnd(i) = CBool(SortIndex(1 + i * 3) * 1 = 1)
* * * stype(i) = CBool(SortIndex(2 + i * 3) * 1 = 0)
* * Next i
* End If

* If bHorizontal Then

* * ReDim B(lb2 To ub2) As Long
* * ReDim C(lb2 To ub2)

* * For i = lb2 To ub2
* * * B(i) = i
* * * C(i) = vArray(sIdx(0), i)
* * Next i

* * TagSort C(), B(), lb2, ub2, dsnd(0), stype(0)

* * For i = lb1 To ub1
* * * For j = lb2 To ub2
* * * * vArray(i, j) = D(i, B(j))
* * * Next j
* * Next i

* * If UBound(sIdx) 0 Then
* * * For z = 1 To UBound(sIdx)
* * * * For i = lb2 To ub2 - 1
* * * * * j = 1

* * * * * Do While IIf(stype(n), vArray(sIdx(0), i) = _
* * * * * * * * * * * * * * * * *vArray(sIdx(0), i + j), _
* * * * * * * * * * * *StrComp(vArray(sIdx(0), i), _
* * * * * * * * * * * * * * * *vArray(sIdx(0), i + j), _
* * * * * * * * * * * * * * * *vbTextCompare) = 0)
* * * * * * For n = 1 To z - 1
* * * * * * * If stype(n) Then
* * * * * * * * If vArray(sIdx(n), i) < vArray(sIdx(n), i + j) Then
* * * * * * * * * Exit Do
* * * * * * * * End If
* * * * * * * Else
* * * * * * * * If StrComp(vArray(sIdx(n), i), _
* * * * * * * * * * * * * *vArray(sIdx(n), i + j), _
* * * * * * * * * * * * * *vbTextCompare) < 0 Then
* * * * * * * * * Exit Do
* * * * * * * * End If
* * * * * * * End If
* * * * * * Next n

* * * * * * j = j + 1
* * * * * * If i + j ub2 Then
* * * * * * * Exit Do
* * * * * * End If
* * * * * Loop

* * * * * If j 1 Then

* * * * * * ReDim B(1 To j) As Long
* * * * * * ReDim C(1 To j)

* * * * * * For k = 1 To j
* * * * * * * B(k) = k
* * * * * * * C(k) = vArray(sIdx(z), i + k - 1)
* * * * * * Next k

* * * * * * TagSort C(), B(), 1, j, dsnd(z), stype(z)

* * * * * * ReDim D(lb1 To ub1, 1 To j)

* * * * * * For k = lb1 To ub1
* * * * * * * For m = 1 To j
* * * * * * * * D(k, m) = vArray(k, i + m - 1)
* * * * * * * Next m
* * * * * * Next k

* * * * * * For k = lb1 To ub1
* * * * * * * For m = 1 To j
* * * * * * * * vArray(k, i + m - 1) = D(k, B(m))
* * * * * * * Next m
* * * * * * Next k

* * * * * * i = i + j - 1
* * * * * End If
* * * * Next i
* * * Next z
* * End If

* Else *'If bHorizontal

* * ReDim B(lb1 To ub1) As Long
* * ReDim C(lb1 To ub1)

* * For i = lb1 To ub1
* * * B(i) = i
* * * C(i) = vArray(i, sIdx(0))
* * Next i

* * TagSort C(), B(), lb1, ub1, dsnd(0), stype(0)

* * For i = lb1 To ub1
* * * For j = lb2 To ub2
* * * * vArray(i, j) = D(B(i), j)
* * * Next j
* * Next i

* * If UBound(sIdx) 0 Then
* * * For z = 1 To UBound(sIdx)
* * * * For i = lb1 To ub1 - 1
* * * * * j = 1

* * * * * Do While IIf(stype(0), vArray(i, sIdx(0)) = _
* * * * * * * * * * * * * * * * *vArray(i + j, sIdx(0)), _
* * * * * * * * * * * *StrComp(vArray(i, sIdx(0)), _
* * * * * * * * * * * * * * * *vArray(i + j, _
* * * * * * * * * * * * * * * * * * * sIdx(0)), vbTextCompare) = 0)
* * * * * * For n = 1 To z - 1
* * * * * * * If stype(n) Then
* * * * * * * * If vArray(i, sIdx(n)) < vArray(i + j, sIdx(n)) Then
* * * * * * * * * Exit Do
* * * * * * * * End If
* * * * * * * Else
* * * * * * * * If StrComp(vArray(i, _
* * * * * * * * * * * * * * * * * sIdx(n)), _
* * * * * * * * * * * * * * * * * vArray(i + j, _
* * * * * * * * * * * * * * * * * * * * *sIdx(n)), _
* * * * * * * * * * * * * * * * * * * * *vbTextCompare) < 0 Then
* * * * * * * * * Exit Do
* * * * * * * * End If
* * * * * * * End If
* * * * * * Next n
* * * * * * j = j + 1
* * * * * * If i + j ub1 Then Exit Do
* * * * * Loop

* * * * * If j 1 Then

* * * * * * ReDim B(1 To j) As Long
* * * * * * ReDim C(1 To j)

* * * * * * For k = 1 To j
* * * * * * * B(k) = k
* * * * * * * C(k) = vArray(i + k - 1, sIdx(z))
* * * * * * Next k

* * * * * * TagSort C(), B(), 1, j, dsnd(z), stype(z)

* * * * * * ReDim D(1 To j, lb2 To ub2)

* * * * * * For k = 1 To j
* * * * * * * For m = lb2 To ub2
* * * * * * * * D(k, m) = vArray(i + k - 1, m)
* * * * * * * Next m
* * * * * * Next k

* * * * * * For k = 1 To j
* * * * * * * For m = lb2 To ub2
* * * * * * * * vArray(i + k - 1, m) = D(B(k), m)
* * * * * * * Next m
* * * * * * Next k

* * * * * * i = i + j - 1
* * * * * End If
* * * * Next i
* * * Next z
* * End If
* End If *'If bHorizontal

* Sort2D = vArray

End Function

Public Function TagSort(C(), _
* * * * * * * * * * * * B() As Long, _
* * * * * * * * * * * * Low As Long, _
* * * * * * * * * * * * Hi As Long, _
* * * * * * * * * * * * Optional Descending As Boolean, _
* * * * * * * * * * * * Optional BinarySort As Boolean)

* On Error Resume Next

* Dim Low2 As Long
* Dim Hi2 As Long
* Dim MidValue
* Dim Temp As Long

* MidValue = C(B((Low + Hi) \ 2))
* Low2 = Low
* Hi2 = Hi

* While (Low2 <= Hi2)
* * If BinarySort Then
* * * If Descending Then
* * * * While (C(B(Low2)) MidValue And Low2 < Hi)
* * * * * Low2 = Low2 + 1
* * * * Wend
* * * * While (C(B(Hi2)) < MidValue And Hi2 Low)
* * * * * Hi2 = Hi2 - 1
* * * * Wend
* * * Else
* * * * While (C(B(Low2)) < MidValue And Low2 < Hi)
* * * * * Low2 = Low2 + 1
* * * * Wend
* * * * While (C(B(Hi2)) MidValue And Hi2 Low)
* * * * * Hi2 = Hi2 - 1
* * * * Wend
* * * End If
* * Else
* * * If Descending Then
* * * * While (StrComp(C(B(Low2)), MidValue, vbTextCompare) 0 _
* * * * * * * *And Low2 < Hi)
* * * * * Low2 = Low2 + 1
* * * * Wend
* * * * While (StrComp(C(B(Hi2)), MidValue, vbTextCompare) < 0 _
* * * * * * * *And Hi2 Low)
* * * * * Hi2 = Hi2 - 1
* * * * Wend
* * * Else
* * * * While (StrComp(C(B(Low2)), MidValue, vbTextCompare) < 0 _
* * * * * * * *And Low2 < Hi)
* * * * * Low2 = Low2 + 1
* * * * Wend
* * * * While (StrComp(C(B(Hi2)), MidValue, vbTextCompare) 0 _
* * * * * * * *And Hi2 Low)
* * * * * Hi2 = Hi2 - 1
* * * * Wend
* * * End If
* * End If

* * If (Low2 <= Hi2) Then
* * * Temp = B(Low2)
* * * B(Low2) = B(Hi2)
* * * B(Hi2) = Temp
* * * Low2 = Low2 + 1
* * * Hi2 = Hi2 - 1
* * End If
* Wend

* If (Hi2 Low) Then
* * TagSort C(), B(), Low, Hi2, Descending, BinarySort
* End If

* If (Low2 < Hi) Then
* * TagSort C(), B(), Low2, Hi, Descending, BinarySort
* End If

End Function

RBS

"Dan" wrote in message

...

Hello

I have a listbox which will be loaded from an array named MyArray(100,5)
My listbox has so 5 columns ....

I desire to order my listbox, after a record insertion, by col 1 and col 0
again.

My idea is to sort my array, before to load it again in the ListBox ...
But how can I do it ?

For the moment I write my Array in a temp sheet range, order there, copy
back to my Array and then reload my ListBox .... pfff :-(

Any other idea ?

Thanks and best regards

Dan