Sorting variant array on multiple columns

Tech-Archive recommends: Fix windows errors by optimizing your registry

Was looking for a routine that sorts variant arrays on multiple columns and there isn't much available it seems.
I found one though posted by Bill McCarthy. Not sure if he wrote it. It seems to work fine, but it is somewhat slow
(actually not that much faster than my old method which was based on SQL on text files via ADO) and I wondered
if anybody had a fast routine available to do this job and would be willing to post it.

This is Bill's code (somewhat adapted, but only cosmetically):

Public Function Sort2DMultipleColumns(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 ParamArray arguments for as many columns you want to sort in the
'appropiate order, eg:
'Sort a 2D array vertically by:
' column 1 descending binary
'then by column 3 descending textual,
'then by column 5 ascending binary use the following syntax:
'Sort2DMultipleColumns A(),False, 1, True, True, 3, True , False, 5 , False, True
'--------------------------------------------------------------------------------

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 lColOrRow() As Long
Dim bDescending() As Boolean
Dim bBinarySort() 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 lColOrRow(0 To 0) As Long
ReDim bDescending(0 To 0) As Boolean
ReDim bBinarySort(0 To 0) As Boolean
lColOrRow(0) = 1
bDescending(0) = True
bBinarySort(0) = True
Else
ReDim lColOrRow(0 To UBound(SortIndex) \ 3)
ReDim bDescending(0 To UBound(SortIndex) \ 3)
ReDim bBinarySort(0 To UBound(SortIndex) \ 3)

For i = 0 To UBound(SortIndex) \ 3
lColOrRow(i) = SortIndex(i * 3)
bDescending(i) = SortIndex(1 + i * 3)
bBinarySort(i) = SortIndex(2 + i * 3)
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(lColOrRow(0), i)
Next i

TagSort C(), B(), LB2, UB2, bDescending(0), bBinarySort(0)

For i = LB1 To UB1
For j = LB2 To UB2
vArray(i, j) = D(i, B(j))
Next j
Next i

If UBound(lColOrRow) > 0 Then
For z = 1 To UBound(lColOrRow)
For i = LB2 To UB2 - 1
j = 1

Do While IIf(bBinarySort(n), vArray(lColOrRow(0), i) = _
vArray(lColOrRow(0), i + j), _
StrComp(vArray(lColOrRow(0), i), _
vArray(lColOrRow(0), i + j), _
vbTextCompare) = 0)
For n = 1 To z - 1
If bBinarySort(n) Then
If vArray(lColOrRow(n), i) <> vArray(lColOrRow(n), i + j) Then
Exit Do
End If
Else
If StrComp(vArray(lColOrRow(n), i), _
vArray(lColOrRow(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(lColOrRow(z), i + k - 1)
Next k

TagSort C(), B(), 1, j, bDescending(z), bBinarySort(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, lColOrRow(0))
Next i

TagSort C(), B(), LB1, UB1, bDescending(0), bBinarySort(0)

For i = LB1 To UB1
For j = LB2 To UB2
vArray(i, j) = D(B(i), j)
Next j
Next i

If UBound(lColOrRow) > 0 Then
For z = 1 To UBound(lColOrRow)
For i = LB1 To UB1 - 1
j = 1

Do While IIf(bBinarySort(0), vArray(i, lColOrRow(0)) = _
vArray(i + j, lColOrRow(0)), _
StrComp(vArray(i, lColOrRow(0)), _
vArray(i + j, _
lColOrRow(0)), vbTextCompare) = 0)
For n = 1 To z - 1
If bBinarySort(n) Then
If vArray(i, lColOrRow(n)) <> vArray(i + j, lColOrRow(n)) Then
Exit Do
End If
Else
If StrComp(vArray(i, _
lColOrRow(n)), _
vArray(i + j, _
lColOrRow(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, lColOrRow(z))
Next k

TagSort C(), B(), 1, j, bDescending(z), bBinarySort(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

Sort2DMultipleColumns = vArray

End Function


Private Function TagSort(C(), _
B() As Long, _
Low As Long, _
Hi As Long, _
Optional bDescending As Boolean, _
Optional bBinarySort 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 bBinarySort Then
If bDescending 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 bDescending 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, bDescending, bBinarySort
End If

If (Low2 < Hi) Then
TagSort C(), B(), Low2, Hi, bDescending, bBinarySort
End If

End Function


RBS

.

Relevant Pages

  • Re: Sorting variant array on multiple columns
    ... In any case you can sometimes improve performance by doing single column bubble sort calls in the correct order, but that really depends on the level of duplicates. ... Dim i As Long ... Dim UB2 As Long ... ReDim bDescendingAs Boolean ...
    (microsoft.public.vb.general.discussion)
  • Re: Sorting variant array on multiple columns
    ... Dim i As Long ... Dim UB1 As Long ... Dim UB2 As Long ... ReDim bDescendingAs Boolean ...
    (microsoft.public.vb.general.discussion)
  • Re: Order in a array / ListBox
    ... Here an array sort I found somewhere that allows sorting on multiple columns: ... Dim i As Long ... Dim ub2 As Long ... ReDim dsndAs Boolean ...
    (microsoft.public.excel.programming)
  • Re: Array Declaration Problem ??
    ... the declaration ReDim awas commented out in Function Zroots. ... Function ZrootsAs Variant() ... Dim j As Integer, its As Integer ... Enter on a worksheet the function "MyRoots() and select a 4 Row*2 Column ...
    (microsoft.public.excel.programming)
  • Need programming PROs help! Quiclk
    ... ProdName As String ... Detail As Boolean ... Dim lstMyProds() As String ... ReDim lstReps ...
    (microsoft.public.excel.programming)