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
