Visual Basic for Applications/Bubble Sort on Multiple Keys

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