Opening the book…
Summary
Array Sort on Three Keys
- This rather long VBA code listing allows bubble sorting of an array on three keys. It is sometimes called an intersort.
- In case it is not clear what that means, suppose there are many names to sort; each with two forenames and a surname. The names records occupy a row each and their parts are in separate columns. The first key might sort the surnames column, but there could be many records called Smith. Then the second key sorts among the first forenames where the surnames were similar. And there might still be a lot of John Smith name records that are the same. The third key sorts the second forename column for those cases where there are records with the same surname and first forename combination.
- A similar function can be found on Excel worksheets in the advanced sort functions. Users unfamiliar with this sort type might well experiment there to better understand the process.
- The function here has options for ascending or descending sorts, row sort or column sort, and the option to return the sorted work in another array or the original. Up to three keys can be specified, though if there are unused keys, say, because only two intersorts are needed, it is assumed that Key1 and Key2 will be used before Key3. In any case, unreasonable settings will result in message box advice.
Function SortArr2D3Keys(vA As Variant, _
Optional Key1 As Long = -1, _
Optional Key2 As Long = -1, _
Optional Key3 As Long = -1, _
Optional ByVal bIsAscending As Boolean = True, _
Optional ByVal bIsRowSort As Boolean = True, _
Optional ByRef vR As Variant) As Boolean
'--------------------------------------------------------------------------------------
' Procedure : SortArr2D3Keys
' Purpose : Bubblesorts a 2D array using 3 keys, up or down, on any column or row.
' For example, sorting using up to three columns;
' Eg; first sorts surnames, then sorts among same surnames for first names,
' then among similar surnames with same first names for middle names.
' Options include in-place, with the source changed, or
' if supplied, returned in vR, with the source array intact.
' Optional parameters default to: ROW SORT, ASCENDING.
' Trailing key options that are not needed should be set to same as previous.
'---------------------------------------------------------------------------------------
ASSIGNMENTS:
Dim condition1 As Boolean, vW As Variant, Temp
Dim i As Long, j As Long, y As Long, t As Variant
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim r As Long, c As Long, bWasMissing As Boolean
Dim sCombo As String, reply
Dim b1Used As Boolean, b2Used As Boolean, b3Used As Boolean
'find bounds of vA data input array
loR = LBound(vA, 1): hiR = UBound(vA, 1)
loC = LBound(vA, 2): hiC = UBound(vA, 2)
'find whether optional vR was initially missing
bWasMissing = IsMissing(vR)
If Not bWasMissing Then Set vR = Nothing
KEYCHECKS:
If Key1 <> -1 Then
b1Used = True
'check key within bounds
If bIsRowSort And (Key1 < loC Or Key1 > hiC) Then
MsgBox "Sort key1 out of bounds"
Exit Function
End If
If Not bIsRowSort And (Key1 < loR Or Key1 > hiR) Then
MsgBox "Sort key1 out of bounds"
Exit Function
End If
End If
If Key2 <> -1 Then
b2Used = True
'check key within bounds
If bIsRowSort And (Key2 < loC Or Key2 > hiC) Then
MsgBox "Sort key2 out of bounds"
Exit Function
End If
If Not bIsRowSort And (Key2 < loR Or Key2 > hiR) Then
MsgBox "Sort key2 out of bounds"
Exit Function
End If
End If
If Key3 <> -1 Then
b3Used = True
'check key within bounds
If bIsRowSort And (Key3 < loC Or Key3 > hiC) Then
MsgBox "Sort key3 out of bounds"
Exit Function
End If
If Not bIsRowSort And (Key3 < loR Or Key3 > hiR) Then
MsgBox "Sort key3 out of bounds"
Exit Function
End If
End If
sCombo = CStr(Abs(b1Used)) & CStr(Abs(b2Used)) & CStr(Abs(b3Used))
'MsgBox sCombo
Select Case sCombo
Case "000"
'no keys selected
If bIsRowSort Then
reply = MsgBox("No keys selected." & vbCrLf & _
"Use lower bound column for a single key?", vbCritical + vbQuestion + vbYesNo, "Please confirm your selection...")
Select Case reply
Case vbYes
Key1 = loC
Case Else
Exit Function
End Select
Else
reply = MsgBox("No keys selected." & vbCrLf & _
"Use lower bound row for a single key?", vbCritical + vbQuestion + vbYesNo, "Please confirm your selection...")
Select Case reply
Case vbYes
Key1 = loR
Case Else
Exit Function
End Select
End If
Case "100", "110", "111"
'proceed normally
Case Else
MsgBox "Only three combinations of sort keys are possible" & vbCrLf & _
"Key1 alone, Key1 with Key2, or Key1 with Key2 and Key3."
Exit Function
End Select
WORKARRAY:
'use a working array for sorting
vW = vA
STEERING:
'steer input options
If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
ROWSORT:
'row sort using 3 intersort keys
'Sort rows of array using first column index, Key1
For i = loR To hiR - 1
For j = i + 1 To hiR
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(i, Key1) > vW(j, Key1)
Else
condition1 = vW(i, Key1) < vW(j, Key1)
End If
If condition1 Then
For c = loC To hiC
Temp = vW(i, c)
vW(i, c) = vW(j, c)
vW(j, c) = Temp
Next
End If
Next
Next
If b2Used Then
'Sort rows of array using second column index, Key2
For i = loR To hiR - 1
For j = i + 1 To hiR
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(i, Key1) = vW(j, Key1) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(i, Key2) > vW(j, Key2)
Else
condition1 = vW(i, Key2) < vW(j, Key2)
End If
If condition1 Then
For c = loC To hiC
Temp = vW(i, c)
vW(i, c) = vW(j, c)
vW(j, c) = Temp
Next
End If
End If
Next
Next
Else
GoTo TRANSFERS
End If
If b3Used Then
'Sort rows of array using third column index, Key3
For i = loR To hiR - 1
For j = i + 1 To hiR
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(i, Key1) = vW(j, Key1) And vW(i, Key2) = vW(j, Key2) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(i, Key3) > vW(j, Key3)
Else
condition1 = vW(i, Key3) < vW(j, Key3)
End If
If condition1 Then
For c = loC To hiC
Temp = vW(i, c)
vW(i, c) = vW(j, c)
vW(j, c) = Temp
Next
End If
End If
Next
Next
End If
GoTo TRANSFERS
COLSORT:
'column sort using 3 intersort keys
'Sort columns of array using first row index, Key1
For i = loC To hiC - 1
For j = i + 1 To hiC
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(Key1, i) > vW(Key1, j)
Else
condition1 = vW(Key1, i) < vW(Key1, j)
End If
If condition1 Then
For c = loR To hiR
Temp = vW(c, i)
vW(c, i) = vW(c, j)
vW(c, j) = Temp
Next
End If
Next
Next
If b2Used Then
'Sort columns of array using second row index, Key2
For i = loC To hiC - 1
For j = i + 1 To hiC
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(Key1, i) = vW(Key1, j) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(Key2, i) > vW(Key2, j)
Else
condition1 = vW(Key2, i) < vW(Key2, j)
End If
If condition1 Then
For c = loR To hiR
Temp = vW(c, i)
vW(c, i) = vW(c, j)
vW(c, j) = Temp
Next
End If
End If
Next
Next
Else
GoTo TRANSFERS
End If
If b3Used Then
'Sort columns of array using third row index, Key2
For i = loC To hiC - 1
For j = i + 1 To hiC
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(Key1, i) = vW(Key1, j) And vW(Key2, i) = vW(Key2, j) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(Key3, i) > vW(Key3, j)
Else
condition1 = vW(Key3, i) < vW(Key3, j)
End If
If condition1 Then
For c = loR To hiR
Temp = vW(c, i)
vW(c, i) = vW(c, j)
vW(c, j) = Temp
Next
End If
End If
Next
Next
End If
GoTo TRANSFERS
TRANSFERS:
'decide whether to return in vA or vR
If Not bWasMissing Then
'vR was the intended return array
'so return vR leaving vA intact
vR = vW
Else:
'vR is not intended
'so reload vA with vR
vA = vW
End If
'set return function value
SortArr2D3Keys = True
End Function
The book could not be loaded just now.