Wikibooks

Visual Basic for Applications/Bubble Sort on Multiple Keys

< Visual Basic for Applications

Summary

edit

Array Sort on Three Keys

edit
  • 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
Retrieved from "https://en.wikibooks.org/w/index.php?title=Visual_Basic_for_Applications/Bubble_Sort_on_Multiple_Keys&oldid=3678919"