Hi,
I have an array that’s currently 50 members by 7 members, and I need to sort this array by the first “column” (the [1][1], [2][1], [3][1], etc. members), which is a primary key, and then a secondary sort by the second column. I’ve seen lots of methods for sorting one-dimensional arrays, but has anybody come up with a good one for multi-dimensional arrays?
Thanks in advance,
Sam
Subject: I wrote this for that purpose, however it was designed to take individual arrays
then sort then pull the sorted lists back out. It handles combinations of text and date/time or numbers.i.e.
Dim slist as new TSSortedLists()
Call slist.AddKeyArray(Array1, “+”)
Call slist.AddKeyArray(Array2, “-”)
Call slist.AddKeyArray(Array3, “+”)
Call slist.AddKeyArray(Array4, “+”)
Call slist.Sort()
SArray1 = slist.GetNthSortedArray(0)
SArray2 = slist.GetNthSortedArray(1)
SArray3 = slist.GetNthSortedArray(2)
SArray4 = slist.GetNthSortedArray(3)
Class TSSortedLists
Public KeyArray As Variant
Public AscDescFlags As Variant
Public Count As Integer
Public DType As Variant
Private nKeys As Integer
Sub New()
End Sub
Sub SwapKeys(p1, p2)
For k = 0 To Me.nKeys
t1 = Me.KeyArray(p1, k)
Me.KeyArray(p1, k) = Me.KeyArray(p2, k)
Me.KeyArray(p2, k) = t1
Next
End Sub
Function CompareKeys(d1, d2)
R1 = 0
For k = 0 To Me.nKeys
Select Case Me.DType(k)
Case "STRING"
tv1 = Me.KeyArray(d1, k)
tv2 = Me.KeyArray(d2, k)
Case "DATE"
tv1 = Cdat(Me.KeyArray(d1, k))
tv2 = Cdat(Me.KeyArray(d2, k))
Case Else
tv1 = Cdbl(Me.KeyArray(d1, k))
tv2 = Cdbl(Me.KeyArray(d2, k))
End Select
If AscDescFlags(k) = "-" Then
If tv1 < tv2 Then
R1 = 1
Exit For
Elseif tv1 > tv2 Then
R1 = -1
Exit For
End If
Elseif AscDescFlags(k) = "+" Then
If tv1 > tv2 Then
R1 = 1
Exit For
Elseif tv1 < tv2 Then
R1 = -1
Exit For
End If
End If
Next
CompareKeys = R1
End Function
Function CompareKeyToSaved(p1, SKA)
R1 = 0
For k = 0 To Me.nKeys
Select Case Me.DType(k)
Case "STRING"
tv1 = Me.KeyArray(p1, k)
tv2 = SKA(k)
Case "DATE"
tv1 = Cdat(Me.KeyArray(p1, k))
tv2 = Cdat(SKA(k))
Case Else
tv1 = Cdbl(Me.KeyArray(p1, k))
tv2 = Cdbl(SKA(k))
End Select
If AscDescFlags(k) = "-" Then
If tv1 < tv2 Then
R1 = 1
Exit For
Elseif tv1 > tv2 Then
R1 = -1
Exit For
End If
Elseif AscDescFlags(k) = "+" Then
If tv1 > tv2 Then
R1 = 1
Exit For
Elseif tv1 < tv2 Then
R1 = -1
Exit For
End If
End If
Next
CompareKeyToSaved = R1
End Function
Function SaveKey(p1)
Redim test1(Me.nKeys)
For k = 0 To Me.nKeys
test1(k) = Me.KeyArray(p1, k)
Next
SaveKey = test1
End Function
Sub RestoreKey(p1, SKA)
For k = 0 To Me.nKeys
Me.KeyArray(p1, k) = SKA(k)
Next
End Sub
Sub DoQS(bottom As Long, top As Long)
Dim length As Long
Dim i As Long
Dim j As Long
Dim Pivot As Long
Dim PivotValue As Variant
Dim t As Variant
Dim LastSmall As Long
length = top - bottom + 1
If length > 10 Then
Pivot = bottom + (length \ 2)
PivotValue = Me.SaveKey(Pivot)
Call Me.SwapKeys(Pivot, bottom)
LastSmall = bottom
For i = bottom + 1 To top
If CompareKeyToSaved(i, PivotValue) = -1 Then
LastSmall = LastSmall + 1
Call Me.SwapKeys(i, LastSmall)
End If
Next
Call Me.SwapKeys(LastSmall, bottom)
Pivot = LastSmall
Call Me.DoQS (bottom, Pivot - 1 )
Call Me.DoQS (Pivot + 1, top )
Else
For i = bottom+1 To top
x = i
test1 = Me.SaveKey(i)
Do While (Me.CompareKeyToSaved(x - 1, test1) > 0)
Call Me.SwapKeys(x, x - 1)
x = x - 1
If x = bottom Then
Exit Do
End If
Loop
Call Me.RestoreKey(x, test1)
Next
End If
End Sub
Sub AddKeyArray(Array1, AscDescFlag)
A1 = SetArray(Array1)
If Isempty(Me.KeyArray) Then
Me.nKeys = 0
Me.Count = Ubound(A1)
Redim Me.KeyArray(Me.Count, Me.nKeys)
Redim Me.AscDescFlags(Me.nKeys)
Redim Me.DType(Me.nKeys)
Else
Me.nKeys = Me.nKeys + 1
Redim Preserve Me.KeyArray(Me.Count, Me.nKeys)
Redim Preserve Me.AscDescFlags(Me.nKeys)
Redim Preserve Me.DType(Me.nKeys)
End If
Me.AscDescFlags(Me.nKeys) = AscDescFlag
Me.DType(nKeys) = Typename(A1(0))
For i = 0 To Me.Count
Me.KeyArray(i, nKeys) = Cstr(A1(i))
Next
End Sub
Function GetNthSortedArray(p1)
Redim r1(Me.Count)
Select Case Me.DType(p1)
Case "STRING"
For i = 0 To Me.Count
r1(i) = Me.KeyArray(i, p1)
Next
Case "DATE"
For i = 0 To Me.Count
r1(i) = Cdat(Me.KeyArray(i, p1))
Next
Case Else
r1(i) = Cdbl(Me.KeyArray(i, p1))
End Select
GetNthSortedArray = r1
End Function
Sub Sort()
Dim bottom As Long, top As Long
bottom = 0
top = Me.Count
Call Me.DoQS(bottom, top)
End Sub
End Class
Subject: RE: I wrote this for that purpose, however it was designed to take individual arrays
Bill,
I tried compiling this and found that you were calling a “SetArray” function that didn’t exist. Do you have code for this function?
Thanks,
Sam
Subject: Sorry (forgot that was in there)…
Function SetArray(S1 As Variant) As Variant’Make sure source was array
Dim T1 'return Array
If Isarray(S1) Then
T1 = S1
Else
Redim T1(0) 'single element array
T1(0) = S1
End If
SetArray = T1
End Function
Subject: RE: Sorry (forgot that was in there)…
Bill:
Looks good! I just broke my test array into two arrays, like so:
=========================================
Sub Initialize
Dim array_test1(0 To 5) As String
Dim array_test2(0 To 5) As String
array_test1(0) = "John"
array_test2(0) = "Lennon"
array_test1(1) = "Paul"
array_test2(1) = "McCartney"
array_test1(2) = "George"
array_test2(2) = "Harrison"
array_test1(3) = "Ringo"
array_test2(3) = "Starr"
array_test1(4) = "George"
array_test2(4) = "Strait"
array_test1(5) = "George"
array_test2(5) = "Clinton"
Dim slist As New TSSortedLists()
Call slist.AddKeyArray(array_test1, "+")
Call slist.AddKeyArray(array_test2, "+")
Call slist.Sort()
SArray1 = slist.GetNthSortedArray(0)
SArray2 = slist.GetNthSortedArray(1)
End Sub
=================================
SArray1 came back with “George, George, George, John, Paul, Ringo” and SArray2 came back with “Clinton, Harrison, Strait, Lennon, McCartney, Starr”.
I just have a couple of questions for you:
(1) I’m using Option Base 1 as a company standard. If I change all the array references to zero in your class to array references to one, will this work for base 1 arrays?
(2) My array is 50 X 7 members, so I potentially have seven one-dimensional array of 50 members if I use this method. I only want to sort by the first two columns, and just keep the other five columns linked to the row their primary key moves to. How do I put the other five one-dimensional arrays in your class without sorting them?
Thanks!
Sam
Subject: Answers
For Q2, it really does not matter if the remaining coulmns you add are sorted or not. i.e. the worst thing that could happen is that Starr|Ringo|Drummer would come before Starr|Ringo|Singer.For Q1 yes or , try this Base independant one:
Class TSSortedLists
Public KeyArray As Variant
Public AscDescFlags As Variant
Public Count As Integer
Public DType As Variant
Private nKeys As Integer
Private lb1 As Integer
Sub New()
Redim a1(1)
Me.Me.lb1 = Lbound(a1)
End Sub
Sub SwapKeys(p1, p2)
For k = Me.lb1 To Me.nKeys
t1 = Me.KeyArray(p1, k)
Me.KeyArray(p1, k) = Me.KeyArray(p2, k)
Me.KeyArray(p2, k) = t1
Next
End Sub
Function CompareKeys(d1, d2)
R1 = 0
For k = Me.lb1 To Me.nKeys
Select Case Me.DType(k)
Case "STRING"
tv1 = Me.KeyArray(d1, k)
tv2 = Me.KeyArray(d2, k)
Case "DATE"
tv1 = Cdat(Me.KeyArray(d1, k))
tv2 = Cdat(Me.KeyArray(d2, k))
Case Else
tv1 = Cdbl(Me.KeyArray(d1, k))
tv2 = Cdbl(Me.KeyArray(d2, k))
End Select
If AscDescFlags(k) = "-" Then
If tv1 < tv2 Then
R1 = 1
Exit For
Elseif tv1 > tv2 Then
R1 = -1
Exit For
End If
Elseif AscDescFlags(k) = "+" Then
If tv1 > tv2 Then
R1 = 1
Exit For
Elseif tv1 < tv2 Then
R1 = -1
Exit For
End If
End If
Next
CompareKeys = R1
End Function
Function CompareKeyToSaved(p1, SKA)
R1 = 0
For k = Me.lb1 To Me.nKeys
Select Case Me.DType(k)
Case "STRING"
tv1 = Me.KeyArray(p1, k)
tv2 = SKA(k)
Case "DATE"
tv1 = Cdat(Me.KeyArray(p1, k))
tv2 = Cdat(SKA(k))
Case Else
tv1 = Cdbl(Me.KeyArray(p1, k))
tv2 = Cdbl(SKA(k))
End Select
If AscDescFlags(k) = "-" Then
If tv1 < tv2 Then
R1 = 1
Exit For
Elseif tv1 > tv2 Then
R1 = -1
Exit For
End If
Elseif AscDescFlags(k) = "+" Then
If tv1 > tv2 Then
R1 = 1
Exit For
Elseif tv1 < tv2 Then
R1 = -1
Exit For
End If
End If
Next
CompareKeyToSaved = R1
End Function
Function SaveKey(p1)
Redim test1(Me.nKeys)
For k = Me.lb1 To Me.nKeys
test1(k) = Me.KeyArray(p1, k)
Next
SaveKey = test1
End Function
Sub RestoreKey(p1, SKA)
For k = Me.lb1 To Me.nKeys
Me.KeyArray(p1, k) = SKA(k)
Next
End Sub
Sub DoQS(bottom As Long, top As Long)
Dim length As Long
Dim i As Long
Dim j As Long
Dim Pivot As Long
Dim PivotValue As Variant
Dim t As Variant
Dim LastSmall As Long
length = top - bottom + 1
If length > 10 Then
Pivot = bottom + (length \ 2)
PivotValue = Me.SaveKey(Pivot)
Call Me.SwapKeys(Pivot, bottom)
LastSmall = bottom
For i = bottom + 1 To top
If CompareKeyToSaved(i, PivotValue) = -1 Then
LastSmall = LastSmall + 1
Call Me.SwapKeys(i, LastSmall)
End If
Next
Call Me.SwapKeys(LastSmall, bottom)
Pivot = LastSmall
Call Me.DoQS (bottom, Pivot - 1 )
Call Me.DoQS (Pivot + 1, top )
Else
For i = bottom+1 To top
x = i
test1 = Me.SaveKey(i)
Do While (Me.CompareKeyToSaved(x - 1, test1) > 0)
Call Me.SwapKeys(x, x - 1)
x = x - 1
If x = bottom Then
Exit Do
End If
Loop
Call Me.RestoreKey(x, test1)
Next
End If
End Sub
Sub AddKeyArray(Array1, AscDescFlag)
A1 = SetArray(Array1)
If Isempty(Me.KeyArray) Then
Me.nKeys = Me.lb1
Me.Count = Ubound(Array1)
Redim Me.KeyArray(Me.Count, Me.nKeys)
Redim Me.AscDescFlags(Me.nKeys)
Redim Me.DType(Me.nKeys)
Else
Me.nKeys = Me.nKeys + 1
Redim Preserve Me.KeyArray(Me.Count, Me.nKeys)
Redim Preserve Me.AscDescFlags(Me.nKeys)
Redim Preserve Me.DType(Me.nKeys)
End If
Me.AscDescFlags(Me.nKeys) = AscDescFlag
Me.DType(nKeys) = Typename(A1(Me.lb1))
For i = Me.lb1 To Me.Count
Me.KeyArray(i, nKeys) = Cstr(A1(i))
Next
End Sub
Function GetNthSortedArray(p1)
Redim r1(Me.Count)
Select Case Me.DType(p1)
Case "STRING"
For i = Me.lb1 To Me.Count
r1(i) = Me.KeyArray(i, p1)
Next
Case "DATE"
For i = Me.lb1 To Me.Count
r1(i) = Cdat(Me.KeyArray(i, p1))
Next
Case Else
r1(i) = Cdbl(Me.KeyArray(i, p1))
End Select
GetNthSortedArray = r1
End Function
Sub Sort()
Dim bottom As Long, top As Long
bottom = Me.lb1
top = Me.Count
Call Me.DoQS(bottom, top)
End Sub
End Class
Subject: This can be much simpler…
Plus it has the benefit of being a stable sort, so matching values in a given
sort column retain their prior sort order.
Oh, and it’s stank-fast. 
[
Sub shellSortMulti (sourceArray As Variant, sortColumn As Integer)]
Dim Lower As Integer
Dim Upper As Integer
Dim botMax As Integer
Dim k As Integer
Dim h As Integer
Dim L1 As Integer
Dim U1 As Integer
Dim tmpArray () As VariantL1 = Lbound(sourceArray, 1) U1 = Ubound(sourceArray, 1) Redim tmpArray (L1 To U1) L2 = Lbound(sourceArray, 2) U2 = Ubound(sourceArray, 2) h = 1 Do h = (3*h) + 1 Loop Until h > U2-L2+1 Do h = h \ 3 botMax = L2 + h - 1 For i = botMax + 1 To U2 For m = L1 To U1 tmpArray(m) = sourceArray(m, i) Next k = i Do While sourceArray(sortColumn, k - h) >tmpArray(sortColumn)
For m = L1 To U1
sourceArray(m, k) = sourceArray(m, k -
h)
Next
k = k - h
If (k <= botMax) Then Exit Do
Loop
If (k <> i) Then
For m = L1 To U1
sourceArray(m, k) = tmpArray(m)
Next
End If
Next
Loop Until h = 1
End Sub
Subject: RE: This can be much simpler…
Nathan:
I tried this code with the following test array:
========================
Sub Initialize
Dim array_test(1 To 6, 1 To 2) As String
array_test(1, 1) = "John"
array_test(1, 2) = "Lennon"
array_test(2, 1) = "Paul"
array_test(2, 2) = "McCartney"
array_test(3, 1) = "George"
array_test(3, 2) = "Harrison"
array_test(4, 1) = "Ringo"
array_test(4, 2) = "Starr"
array_test(5, 1) = "George"
array_test(5, 2) = "Strait"
array_test(6, 1) = "George"
array_test(6, 2) = "Clinton"
Call shellSortMulti(array_test, 1)
End Sub
==============================
…and it didn’t sort at all. I also tried calling shellSortMulti(array_test, 2) with the same results.
The code I had posted before will sort by the first column, but not by the second, i.e.
George Strait
George Clinton
George Harrison
John Lennon
Paul McCartney
Ringo Starr
What I want is code that will primarily sort by the first column, and secondarily sort by the second, like so:
George Clinton
George Harrison
George Strait
John Lennon
Paul McCartney
Ringo Starr
Any thoughts? Or am I just not using your array properly?
Thanks again,
Sam
Subject: RE: This can be much simpler…
That’s why the fact that it’s a stable sort is so important. Just loop the sort and sort the columns in reverse order of priority.
Call shellSortMulti(array_test, 2)
Call shellSortMulti(array_text, 1)
By the way, that’s a band I’d like to hear.
Subject: RE: This can be much simpler…
Yeah, the band would be pretty good as long as George Strait wasn’t singing… =)
OK, after shellSortMulti(array_test, 2) is called, it doesn’t sort, but instead inverts the columns, like so:
Lennon John
McCartney Paul
Harrison George
Starr Ringo
Strait George
Clinton George
And then the call to shellSortMulti(array_test, 1) inverts the columns again! So I’m left with my original, unsorted array.
I’ll take a look at the code this wkend to see if I can figure out why this happening (my guess is that it’s attempting to sort the wrong dimension), but you said the code was stable, so I wanted to confirm that I wasn’t missing something obvious.
Subject: RE: This can be much simpler…
Your array is inverted from how the code expects.
Try this…
[
Sub Initialize]
Dim array_test(1, 5) As Stringarray_test(0, 0) = "John" array_test(0, 1) = "Paul" array_test(0, 2) = "George" array_test(0, 3) = "Ringo" array_test(0, 4) = "George" array_test(0, 5) = "George" array_test(1, 0) = "Lennon" array_test(1, 1) = "McCartney" array_test(1, 2) = "Harrison" array_test(1, 3) = "Starr" array_test(1, 4) = "Strait" array_test(1, 5) = "Clinton" Call shellSortMulti (array_test, 1) Call shellSortMulti (array_test, 0)End Sub
The idea is that only the last dimension of a multi-dimensional array is
dynamic. Because it’s more likely that you have a static number of columns,
with a dynamic number of rows, the multi-dimension sort organizes the “rows”
according to their values in “columns.”
Make sense?
Subject: RE: This can be much simpler…
Yep, that makes sense. Actually, my production data is set up that way, as opposed to the test array I’ve been playing with. When I tried your code on the development server, it worked like a champ! And it was stank fast, as promised.
Thanks for the help, all!
Sam
Subject: LS sorting algorithm for multi-dimensional arrays
I have not attempted that, but thinking out the logic you can sort the first “column” like you would any normal way of sorting. There was a good speed sort routine in the R5 forum many many months ago.
After the first “column” data is sorted I would then do the second column sort.
I guess what I wanted to ask too will the first “column” have similar values but the second “column” will have more unique values?
HTH – Cheers
Subject: RE: LS sorting algorithm for multi-dimensional arrays
Joe,
Thanks for the response. Yes, the second column has more unique values than the first. For example, the value that should appear first in the first “column” appears eight times, and for each of those eight “rows” of data, the second “column” has a different value (something like a categorized view with eight documents inside the first category, if that makes sense).
Here’s something I found here and played with that works pretty nicely to sort my array by the first column; however, there is no secondary sort. I wonder if there’s a way to sort the whole shebang by the primary column, feed each “category” back into the code and sort by the second column…?
Any help is appreciated,
Sam
================================
Sub shellSort(sourceArray() As String)
Dim Lower As Integer
Dim Upper As Integer
Dim botMax As Integer
Dim i As Integer
Dim k As Integer
Dim h As Integer
Dim a As Integer
Dim curVal() As String
Lower = Lbound(sourceArray, 2)
Upper = Ubound(sourceArray, 2)
h = 1
Do
’ Determine starting h
h = (3*h) + 1
Loop Until h > Upper-Lower+1
Do
h = h \ 3
botMax = Lower + h - 1
For i = botMax + 1 To Upper
For a = 1 To Ubound(sourceArray, 1)
Redim Preserve curVal(a)
curVal(a) = sourceArray(a, i)
Next
k = i
Do While sourceArray(1, (k - h)) > curVal(1)
For a = 1 To Ubound(sourceArray, 1)
sourceArray(a, k) = sourceArray(a, (k - h))
Next
k = k - h
If (k <= botMax) Then Exit Do
Loop
wOut:
If (k <> i) Then
For a = 1 To Ubound(sourceArray, 1)
sourceArray(a, k) = curVal(a)
Next
End If
Next
Loop Until h = 1
End Sub