Re: Sorting variant array on multiple columns

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

Wow where you'd dig that oldie up from ?

Yes, it was posted 11 years ago:
http://groups.google.co.uk/group/microsoft.public.vb.syntax/browse_frm/thread/6ce791e469df0229/0e96ecce282257ad?hl=en&lnk=st&q=Function+Sort2D#0e96ecce282257ad

Will have a look at your suggestions.

RBS


"Bill McCarthy" <Bill@xxxxxxxxxxxxx> wrote in message news:A43C06FB-4E84-4882-B96E-CC62D9CA9EFF@xxxxxxxxxxxxxxxx
Hi bart,

Wow where you'd dig that oldie up from ? In any case you can sometimes improve performance by doing single column bubble sort calls in the correct order (least important first), but that really depends on the level of duplicates. And hard coding the routine for a particular case may help too.
How much data are you dealing with, and what is the shape/types of the data ? If the majority of your data is strings, then swapping elements in VB6 causes copying of the strings. In this case you can improve performance by using a bubble sort that swaps the pointers around. See the code samples at this old article:
http://vb.mvps.org/articles/bb200007.asp
I think the routine in question is the one that sorts a list of files. Not you will need to change the path as by default it does all files on C drive which now crashes due to the listbox 32K of items being exceeded ;) But that does a bubble sort, compares the strings, and then swaps the pointers.
Likewise, having the data strongly typed will improve comparison operations dramatically.



"RB Smissaert" <bartsmissaert@xxxxxxxxxxxxxxxx> wrote in message news:O2PlaORFJHA.3288@xxxxxxxxxxxxxxxxxxxxxxx
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)
  • 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)