• Home
 · 
• Miscellaneous
 · 
• Sorts a single or multidimensional array by 1 or 2 columns and keeps the state of the data.

Sorts a single or multidimensional array by 1 or 2 columns and keeps the state of the data.

Sorts a single or multidimensional array by 1 or 2 columns and keeps the state of the data.

Rate Sorts a single or multidimensional array by 1 or 2 columns and keeps the state of the data.

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'Name:      gbBubbleSortArray
'Purpose:   sorts a single dimension or multidimensional array by either one column or two columns
'Inputs:    An array passed by reference
'           The first column to sort on (default 0)
'           The second column to sort on (default NULL ie nothing)
'           The sort order of thew two columns, default Descending
'Process:   Sorts primary column (column 1) by calling the same function
'           Sorts secondary column
'Outputs:   Nothing (boolean success or failure return to be implemented)
'Warning:   The array structure is assumed to be one where the first dimension is the
'           column definitions and the second dimension are the rows
'           It sorts laterally not vertically !!!!!
'           ie  0   1   2   3   4
'           0   70  71  72  73  74
'           1   809 809 88  90  755

'           In the example above: Dimension 1 consists of 2 rows, these are the columns
'           0 is the contact id
'           1 is the company id
'           The columns moving from left to right are the record values
'           The reason for this is that most of my arrays are populated from the GetRows() method
'           and it places it in this structure.
'           Visual Basic array handling mechanisms, only the last dimension can be expanded


Public Function gbBubbleSortArray(ByRef rvntArray As Variant, _
                                    Optional ByVal vbTwoDimensions As Boolean = False, _
                                    Optional ByVal vvntColumnToSortOn As Integer = 0, _
                                    Optional ByVal vvnt2ndColumnSortOn As Variant = Null, _
                                    Optional ByVal vbDescending As Boolean = True) As Boolean
                                    
                                    
Dim bSorted As Boolean: Dim bSwap As Boolean
Dim lCounter As Long: Dim lItems As Long: Dim lStart As Long: Dim lFields As Long: Dim lFieldCounter As Long
Dim vntTemp, vntCol1Val, vntCol2Val As Variant, vntCol1PrevVal, vntCol2PrevVal

'Determine Dimensions
If vbTwoDimensions = True Then
    lStart = LBound(rvntArray, 2): lItems = UBound(rvntArray, 2): lFields = UBound(rvntArray, 1)
Else
    lStart = LBound(rvntArray): lItems = UBound(rvntArray)
End If

'If there is a second column to sort on then sort on primary column first
If Not IsNull(vvnt2ndColumnSortOn) Then gbBubbleSortArray rvntArray, True, vvntColumnToSortOn, , vbDescending

Do While bSorted = False
    
    bSorted = True
    
    For lCounter = lItems - 1 To lStart Step -1
        
        bSwap = False
        
        'SINGLE DIMENSION
        If vbTwoDimensions = False Then
                    
            'DESCENDING SORT ON SINGLE DIMENSION
            If vbDescending = False Then
                If rvntArray(lCounter + 1) < rvntArray(lCounter) Then
                    bSorted = False
                    bSwap = True
                End If
                
            'ASCENDING SORT ON SINGLE DIMENSION
            Else
                If rvntArray(lCounter + 1) > rvntArray(lCounter) Then
                    bSorted = False
                    bSwap = True
                End If
                
            End If
        
            'Check if we need to swap values
            If bSwap = True Then
                bSwap = False
                vntTemp = rvntArray(lCounter)
                rvntArray(lCounter) = rvntArray(lCounter + 1)
                rvntArray(lCounter + 1) = vntTemp
            End If
        
        '****** 2 DIMENSION DATA SET
        Else
            
            'DESCENDING SORT ON 2 DIMENSIONS
            If vbDescending = False Then
                
                'TWO COLUMN SORT
                If Not IsNull(vvnt2ndColumnSortOn) = True Then
                    
                    If rvntArray(vvntColumnToSortOn, lCounter + 1) = rvntArray(vvntColumnToSortOn, lCounter) And rvntArray(vvnt2ndColumnSortOn, lCounter + 1) < rvntArray(vvnt2ndColumnSortOn, lCounter) Then
                        bSorted = False
                        bSwap = True
                    End If
                    
                '1 COLUMN SORT
                Else
                    
                    If rvntArray(vvntColumnToSortOn, lCounter + 1) < rvntArray(vvntColumnToSortOn, lCounter) Then
                        bSorted = False
                        bSwap = True
                    End If
                    
                End If
            
            'ASCENDING SORT
            Else
                If Not IsNull(vvnt2ndColumnSortOn) = True Then
                    
                    If rvntArray(vvntColumnToSortOn, lCounter + 1) = rvntArray(vvntColumnToSortOn, lCounter) And rvntArray(vvnt2ndColumnSortOn, lCounter + 1) > rvntArray(vvnt2ndColumnSortOn, lCounter) Then
                        bSorted = False
                        bSwap = True
                    End If
                    
                Else
                    
                    If rvntArray(vvntColumnToSortOn, lCounter + 1) > rvntArray(vvntColumnToSortOn, lCounter) Then
                        bSorted = False
                        bSwap = True
                    End If
                    
                        
                End If
              End If
            
            
            'Check if we need to swap values
            If bSwap = True Then
                
                For lFieldCounter = 0 To lFields
                    bSwap = False
                    vntTemp = rvntArray(lFieldCounter, lCounter)
                    rvntArray(lFieldCounter, lCounter) = rvntArray(lFieldCounter, lCounter + 1)
                    rvntArray(lFieldCounter, lCounter + 1) = vntTemp
                Next lFieldCounter
            
            End If
            
       'END OF DIMENSION CHECK
       End If
    
    Next lCounter

Loop
    
End Function