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

There are several ways to do that without a sort in a sheet.
This is one of them, using SQL via ADO on a text file:

Option Explicit
Private oADOTextConn As Object
Private Const TempTablesFolder As String = "C:\"
Private Const strTextConn = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\;" & _
"Extended Properties=Text;"

Sub test()

Dim arr

arr = Range(Cells(1), Cells(3, 2))

SQLArraySort arr, 1, "A", False, True, True, 2, , , 2, "D"

Range(Cells(4), Cells(3, 5)) = arr

End Sub


Sub SQLArraySort(arrData As Variant, _
lSortField1 As Long, _
strSortType1 As String, _
bHasFields As Boolean, _
bArrayInput As Boolean, _
bArrayOutput As Boolean, _
Optional lCols As Long, _
Optional strInputFile As String, _
Optional strOutputFile As String, _
Optional lSortField2 As Long, _
Optional strSortType2 As String)

Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
Dim c As Long
Dim strFields As String
Dim arrFields
Dim strQuery As String
Dim strOrderString As String
Dim strTempFile As String
Dim strSortedFile As String
Dim strSchemaFile As String

On Error GoTo ERROROUT

If Len(strInputFile) = 0 Then
strTempFile = TempTablesFolder & "tmpFile.txt"
strInputFile = "tmpFile.txt"
Else
strTempFile = TempTablesFolder & strInputFile
End If

If Len(strOutputFile) = 0 Then
strSortedFile = TempTablesFolder & "SortedFile.txt"
strOutputFile = "SortedFile.txt"
Else
strSortedFile = TempTablesFolder & strOutputFile
End If

strSchemaFile = TempTablesFolder & "Schema.ini"

If bArrayInput Then
KillFile strTempFile
End If

KillFile strSortedFile

KillFile strSchemaFile

If bArrayInput = False Then
If bHasFields = False Then
'working directly with a text file that has no fields yet
'--------------------------------------------------------
strFields = "Field" & c
If lCols 1 Then
For c = 2 To lCols
strFields = strFields & ", Field" & c
Next c
End If
InsertLineAtBeginningTextFile strTempFile, strFields
Else
'working directly with a text file that has fields already
'---------------------------------------------------------
strFields = GetFieldsFromText(strTempFile, lCols)
End If
End If 'If bArrayInput = False

If bArrayInput Then

LB1 = LBound(arrData)
UB1 = UBound(arrData)
LB2 = LBound(arrData, 2)
UB2 = UBound(arrData, 2)

ReDim arrFields(LB2 To UB2) As String

'make the fields string and fields array
'---------------------------------------
If bHasFields = False Then
strFields = "Field" & 1 - LB2
arrFields(LB2) = "Field" & 1 - LB2
If UB1 LB1 Then
For c = LB2 + 1 To UB2
strFields = strFields & ", " & "Field" & c + (1 - LB2)
arrFields(c) = "Field" & c + (1 - LB2)
Next c
End If
Else
strFields = arrData(LB1, LB2)
arrFields(LB2) = arrData(LB1, LB2)
If UB1 LB1 Then
For c = LB2 + 1 To UB2
strFields = strFields & ", " & arrData(LB1, LB2 + c)
arrFields(c) = arrData(LB1, LB2 + c)
Next c
End If
End If 'If bHasFields = False

'write the array to text
'-----------------------
If bHasFields = False Then
SaveArrayToText strTempFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2, _
arrFields
Else
SaveArrayToText strTempFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2
End If
End If 'If bArrayInput = True

'make the SQL ORDER clause
'-------------------------
If lSortField2 = 0 Then
If strSortType1 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " DESC"
End If
Else
If strSortType1 = "A" Then
If strSortType2 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " ASC, " & _
lSortField2 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " ASC, " & _
lSortField2 & " DESC"
End If
Else
If strSortType2 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " DESC, " & _
lSortField2 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " DESC, " & _
lSortField2 & " DESC"
End If
End If
End If 'If lSortField2 = 0

'run the SQL to sort the text file
'---------------------------------
strQuery = "SELECT " & _
strFields & _
" INTO " & strOutputFile & _
" IN '" & TempTablesFolder & "' " & _
"'Text;FMT=Delimited' " & _
"FROM " & _
strInputFile & " " & _
strOrderString

OpenConnection strTextConn
ExecuteAction strQuery

If bArrayOutput Then
'write the textfile back to the array
'------------------------------------
If bHasFields Then
OpenTextFileToArray strSortedFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2
Else
OpenTextFileToArray strSortedFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2, _
True
End If
End If 'If bArrayOutput = Tru

Exit Sub
ERROROUT:

MsgBox "The sub SQLArraySort couldn't complete" & _
vbCrLf & _
"due to an error" & _
vbCrLf & vbCrLf & _
"Error number: " & Err.Number & _
vbCrLf & vbCrLf & _
Err.Description, , "SQLArraySort"

End Sub

Sub SaveArrayToText(ByVal strFile As String, _
ByRef arr As Variant, _
Optional ByVal LB As Long = -1, _
Optional ByVal UB As Long = -1, _
Optional ByVal LB2 As Long = -1, _
Optional ByVal UB2 As Long = -1, _
Optional ByRef fieldArr As Variant, _
Optional bTranspose As Boolean)

Dim r As Long
Dim c As Long
Dim hFile As Long
Dim str As String

If LB = -1 Then
LB = LBound(arr, 1)
End If

If UB = -1 Or UB UBound(arr) Then
UB = UBound(arr, 1)
End If

If LB2 = -1 Then
LB2 = LBound(arr, 2)
End If

If UB2 = -1 Or UB2 UBound(arr, 2) Then
UB2 = UBound(arr, 2)
End If

hFile = FreeFile

Open strFile For Output As hFile

If bTranspose Then
If IsMissing(fieldArr) Then
For r = LB2 To UB2
For c = LB To UB
If c = UB Then
Write #hFile, arr(c, r)
Else
Write #hFile, arr(c, r);
End If
Next
Next
Else
For c = LB To UB
If c = UB Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next
For r = LB2 To UB2
For c = LB To UB
If c = UB Then
Write #hFile, arr(c, r)
Else
Write #hFile, arr(c, r);
End If
Next
Next
End If
Else
If IsMissing(fieldArr) Then
For r = LB To UB
For c = LB2 To UB2
If c = UB2 Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
Else
For c = LB2 To UB2
If c = UB2 Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next
For r = LB To UB
For c = LB2 To UB2
If c = UB2 Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
End If
End If

Close #hFile

End Sub

Function KillFile(strFile As String) As Boolean

On Error GoTo ERROROUT

If bFileExists(strFile) Then
Kill strFile
KillFile = True
End If

ERROROUT:

End Function

Function bFileExists(ByVal sFile As String) As Boolean

Dim lAttr As Long

On Error Resume Next
lAttr = GetAttr(sFile)
bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0)
On Error GoTo 0

End Function

Sub InsertLineAtBeginningTextFile(strFile As String, strLine As String)

Dim strBuffer As String

strBuffer = OpenTextFileToString3(strFile)

If Right$(strLine, 2) = vbCrLf Then
strBuffer = strLine & strBuffer
Else
strBuffer = strLine & vbCrLf & strBuffer
End If

StringToTextFile strFile, strBuffer

End Sub

Sub StringToTextFile(strFile As String, strText As String)

Dim hFile As Long

On Error GoTo ERROROUT

hFile = FreeFile
Open strFile For Binary As #hFile
Put #hFile, , strText
Close #hFile

Exit Sub
ERROROUT:

If hFile 0 Then
Close #hFile
End If

End Sub

Function GetFieldsFromText(ByVal strFile As String, ByVal lCols As Long) As
String

Dim hFile As Long
Dim strTemp As String
Dim strResult As String
Dim c As Long

hFile = FreeFile

Open strFile For Input As #hFile

On Error Resume Next

For c = 1 To lCols
Input #hFile, strTemp
If c = 1 Then
strResult = strTemp
Else
strResult = strResult & ", " & strTemp
End If
Next c

Close #hFile

GetFieldsFromText = strResult

End Function

Sub OpenConnection(strConnString As String)

If oADOTextConn Is Nothing Then
Set oADOTextConn = CreateObject("ADODB.Connection")
End If

If oADOTextConn.State = 0 Then
oADOTextConn.Open strConnString
End If

End Sub

Function ExecuteAction(strCommand As String) As Long

On Error GoTo ERROROUT

oADOTextConn.Execute strCommand, ExecuteAction, 128 'adExecuteNoRecords

Exit Function
ERROROUT:

MsgBox Err.Description, , "Error in Function ExecuteAction"

End Function

Function OpenTextFileToArray(ByRef txtFile As String, _
ByRef arr As Variant, _
ByVal LBRow As Long, _
ByVal UBRow As Long, _
ByVal LBCol As Long, _
ByVal UBCol As Long, _
Optional ByRef bSkipFields As Boolean) As
Variant

Dim hFile As Long
Dim r As Long
Dim c As Long
Dim varWaste

hFile = FreeFile

Open txtFile For Input As #hFile

On Error Resume Next

If bSkipFields = False Then
For r = LBRow To UBRow
For c = LBCol To UBCol
Input #hFile, arr(r, c)
Next
Next
Else
For c = LBCol To UBCol
Input #hFile, varWaste
Next
For r = LBRow To UBRow
For c = LBCol To UBCol
Input #hFile, arr(r, c)
Next
Next
End If

Close #hFile

OpenTextFileToArray = arr

End Function

Function OpenTextFileToString3(ByVal strFile As String) As String

Dim hFile As Long

On Error GoTo ERROROUT

hFile = FreeFile
Open strFile For Binary As #hFile
OpenTextFileToString3 = Space(LOF(hFile))
Get hFile, , OpenTextFileToString3
Close #hFile

Exit Function
ERROROUT:

If hFile 0 Then
Close #hFile
End If

End Function


I know it is a lot of code, but I find it can be quite fast, but haven't
compared with sorting in a sheet.

A better (faster) option might be to use the function HSort in the xll that
is made freely available by Laurent Long
http://xcell05.free.fr/morefunc/english/index.htm

A third option will be to adapt a QuickSort array sorting function. All the
ones I have seen work on one column only, but it
shouldn't be that much trouble to adapt for multiple columns.


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

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

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