Sorting data using VBA: Merge Sort

 2020-06-14    Sorting    0    293

MergeSort: Sorting large two-dimensional arrays:
MergeSort is suitable for sorting two-dimensional arrays very fast, it is almost as fast as the built-in sort in Excel.
MergeSort is a stable sort method, items with equal sort keys are returned in the same order in the sorted result as they had before being sorted.
MergeSort can also be used to sort two-dimensional arrays that has a header row.

NOTE: The sorting algorithm in this document is adapted for use in VBA based on detailed descriptions found in Wikipedia.

Sub MergeSort(varArray As Variant, Optional lngSortColumn As Long = -1, Optional blnCompareText As Boolean = False, _
    Optional blnHasHeaderRow As Boolean = False, Optional lngSortOrder As XlSortOrder = xlAscending)
' updated 2019-05-16 by OPE
' sorts a two-dimensional array in ascending or descending order based on the content in column lngSortColumn
' lngSortColumn must be an integer number >= LBound(varArray, 2) and <= UBound(varArray, 2), uses LBound(varArray, 2) if lngSortColumn < 0
' fast and stable sort method, items with equal sort keys are returned in the same order in the sorted result as they had before being sorted
' example: MergeSort varArrayVariable, 1
Dim i As Long, j As Long, varArray1 As Variant, varArray2 As Variant
Dim blnTwoItemsOnly As Boolean, blnSwap As Boolean, c As Long, varTemp As Variant, varCaption As Variant
    If MergeSort_DimCount(varArray, i, j) <> 2 Then Exit Sub
    
    If blnHasHeaderRow Then
        If i <= 2 Then Exit Sub ' nothing to sort
    Else
        If i <= 1 Then Exit Sub ' nothing to sort
    End If
    If j < 1 Then Exit Sub ' nothing to sort
    
    If lngSortColumn < 0 Then lngSortColumn = LBound(varArray, 2)
    If lngSortColumn < LBound(varArray, 2) Or lngSortColumn > UBound(varArray, 2) Then Exit Sub
    
    blnTwoItemsOnly = False
    If blnHasHeaderRow And i = 3 Then
        blnTwoItemsOnly = True
        i = LBound(varArray, 1) + 1
    End If
    If Not blnHasHeaderRow And i = 2 Then
        blnTwoItemsOnly = True
        i = LBound(varArray, 1)
    End If
    If blnTwoItemsOnly Then
        blnSwap = False
        If lngSortOrder = xlAscending Then ' xlAscending=1, xlDescending=2
            If blnCompareText Then
                blnSwap = StrComp(varArray(i, lngSortColumn), varArray(i + 1, lngSortColumn), vbTextCompare) > 0
            Else
                blnSwap = varArray(i, lngSortColumn) > varArray(i + 1, lngSortColumn)
            End If
        Else
            If blnCompareText Then
                blnSwap = StrComp(varArray(i, lngSortColumn), varArray(i + 1, lngSortColumn), vbTextCompare) < 0
            Else
                blnSwap = varArray(i, lngSortColumn) < varArray(i + 1, lngSortColumn)
            End If
        End If
        If blnSwap Then
            For c = LBound(varArray, 2) To UBound(varArray, 2)
                varTemp = varArray(i, c)
                varArray(i, c) = varArray(i + 1, c)
                varArray(i + 1, c) = varTemp
            Next c
        End If
        Exit Sub
    End If
    
    If blnHasHeaderRow Then
        i = LBound(varArray, 1)
        varCaption = varArray(i, lngSortColumn) ' save original column header
        If blnCompareText Then
            If lngSortOrder = xlAscending Then ' xlAscending=1, xlDescending=2
                varArray(i, lngSortColumn) = Empty
            Else
                varArray(i, lngSortColumn) = Replace(Space(30), " ", "å") ' this might be a different character depending on the regional settings
            End If
        Else
            If lngSortOrder = xlAscending Then ' xlAscending=1, xlDescending=2
                varArray(i, lngSortColumn) = -1E+300 ' very large negative number
            Else
                varArray(i, lngSortColumn) = 1E+300 ' very large positive number
            End If
        End If
    End If
    
    MergeSort_Split varArray, varArray1, varArray2
    If IsArray(varArray1) Then
        MergeSort varArray1, lngSortColumn, blnCompareText, blnHasHeaderRow, lngSortOrder
    End If
    If IsArray(varArray2) Then
        MergeSort varArray2, lngSortColumn, blnCompareText, False, lngSortOrder
    End If
    varArray = MergeSort_Merge(varArray1, varArray2, lngSortColumn, blnCompareText, lngSortOrder)
    If blnHasHeaderRow Then
        i = LBound(varArray, 1)
        varArray(i, lngSortColumn) = varCaption ' restore original column header
    End If
End Sub

Private Sub MergeSort_Split(varArray As Variant, Optional varArray1 As Variant, Optional varArray2 As Variant)
' updated 2019-05-16 by OPE
' splits a two-dimensional array into two two-dimensional arrays: varArray1 and varArray2
Dim i As Long, lngCount As Long, m As Long, v() As Variant, r As Long, c As Long
    varArray1 = False: varArray2 = False
    i = MergeSort_DimCount(varArray, lngCount) ' dimension count and items count
    If i <> 2 Then Exit Sub ' not a two-dimensional array
    If lngCount < 1 Then Exit Sub ' no content in array
    
    If lngCount = 1 Then ' nothing to split
        varArray1 = varArray
        Exit Sub
    End If
    
    m = Int(lngCount / 2)
    If lngCount Mod 2 <> 0 Then m = m + 1
    
    ReDim v(LBound(varArray, 1) To LBound(varArray, 1) + m - 1, LBound(varArray, 2) To UBound(varArray, 2))
    i = LBound(varArray, 1) - 1
    ' add items
    For r = LBound(varArray, 1) To LBound(varArray, 1) + m - 1
        i = i + 1
        For c = LBound(varArray, 2) To UBound(varArray, 2)
            v(i, c) = varArray(r, c)
        Next c
    Next r
    varArray1 = v
    
    If lngCount Mod 2 = 0 Then
        ReDim v(LBound(varArray, 1) To LBound(varArray, 1) + m - 1, LBound(varArray, 2) To UBound(varArray, 2))
    Else
        ReDim v(LBound(varArray, 1) To LBound(varArray, 1) + m - 2, LBound(varArray, 2) To UBound(varArray, 2))
    End If
    i = LBound(varArray, 1) - 1
    ' add items
    For r = LBound(varArray, 1) + m To UBound(varArray, 1)
        i = i + 1
        For c = LBound(varArray, 2) To UBound(varArray, 2)
            v(i, c) = varArray(r, c)
        Next c
    Next r
    varArray2 = v
End Sub

Private Function MergeSort_Merge(varArray1 As Variant, varArray2 As Variant, Optional lngSortColumn As Long = -1, _
    Optional blnCompareText As Boolean = False, Optional lngSortOrder As XlSortOrder = xlAscending) As Variant
' updated 2019-05-16 by OPE
' merges two two-dimensional arrays into one in ascending or descending order
Dim lngRows(0 To 2) As Long, lngCols As Long, r As Long, c As Long, i As Long, j As Long
Dim varArray() As Variant, i1 As Long, i2 As Long
    MergeSort_Merge = False
    i = MergeSort_DimCount(varArray1, lngRows(1)) ' dimension count and items count
    j = MergeSort_DimCount(varArray2, lngRows(2)) ' dimension count and items count
    If i <> 2 And j <> 2 Then Exit Function ' not two two-dimensional arrays

    If lngRows(1) < 1 Then ' no content i array1
        If lngRows(2) > 0 Then ' has content i array2
            MergeSort_Merge = varArray2
        End If
        Exit Function
    End If

    If lngRows(2) < 1 Then ' no content i array2
        If lngRows(1) > 0 Then ' has content i array1
            MergeSort_Merge = varArray1
        End If
        Exit Function
    End If
    
    If lngSortColumn < 0 Then lngSortColumn = LBound(varArray1, 2)
    If lngSortColumn < LBound(varArray1, 2) Or lngSortColumn > UBound(varArray1, 2) Then Exit Function
    If lngSortColumn < LBound(varArray2, 2) Or lngSortColumn > UBound(varArray2, 2) Then Exit Function
    
    lngRows(0) = lngRows(1) + lngRows(2) ' total row count
    
    lngCols = UBound(varArray1, 2) - LBound(varArray1, 2) + 1
    c = UBound(varArray2, 2) - LBound(varArray2, 2) + 1
    If c > lngCols Then lngCols = c
    
    ReDim varArray(LBound(varArray1, 1) To lngRows(0) + LBound(varArray1, 1) - 1, LBound(varArray1, 2) To lngCols + LBound(varArray1, 2) - 1) ' result array
    r = LBound(varArray1, 1) - 1
    i1 = LBound(varArray1, 1)
    i2 = LBound(varArray2, 1)
    Do While i1 <= UBound(varArray1, 1) And i2 <= UBound(varArray2, 1)
        r = r + 1
        c = LBound(varArray, 2) - 1
        If lngSortOrder = xlAscending Then ' xlAscending=1, xlDescending=2
            If blnCompareText Then
                If StrComp(varArray1(i1, lngSortColumn), varArray2(i2, lngSortColumn), vbTextCompare) <= 0 Then
                    For j = LBound(varArray1, 2) To UBound(varArray1, 2)
                        c = c + 1
                        varArray(r, c) = varArray1(i1, j)
                    Next j
                    i1 = i1 + 1
                Else
                    For j = LBound(varArray2, 2) To UBound(varArray2, 2)
                        c = c + 1
                        varArray(r, c) = varArray2(i2, j)
                    Next j
                    i2 = i2 + 1
                End If
            Else
                If varArray1(i1, lngSortColumn) <= varArray2(i2, lngSortColumn) Then
                    For j = LBound(varArray1, 2) To UBound(varArray1, 2)
                        c = c + 1
                        varArray(r, c) = varArray1(i1, j)
                    Next j
                    i1 = i1 + 1
                Else
                    For j = LBound(varArray2, 2) To UBound(varArray2, 2)
                        c = c + 1
                        varArray(r, c) = varArray2(i2, j)
                    Next j
                    i2 = i2 + 1
                End If
            End If
        Else
            If blnCompareText Then
                If StrComp(varArray1(i1, lngSortColumn), varArray2(i2, lngSortColumn), vbTextCompare) >= 0 Then
                    For j = LBound(varArray1, 2) To UBound(varArray1, 2)
                        c = c + 1
                        varArray(r, c) = varArray1(i1, j)
                    Next j
                    i1 = i1 + 1
                Else
                    For j = LBound(varArray2, 2) To UBound(varArray2, 2)
                        c = c + 1
                        varArray(r, c) = varArray2(i2, j)
                    Next j
                    i2 = i2 + 1
                End If
            Else
                If varArray1(i1, lngSortColumn) >= varArray2(i2, lngSortColumn) Then
                    For j = LBound(varArray1, 2) To UBound(varArray1, 2)
                        c = c + 1
                        varArray(r, c) = varArray1(i1, j)
                    Next j
                    i1 = i1 + 1
                Else
                    For j = LBound(varArray2, 2) To UBound(varArray2, 2)
                        c = c + 1
                        varArray(r, c) = varArray2(i2, j)
                    Next j
                    i2 = i2 + 1
                End If
            End If
        End If
    Loop
    
    Do While i1 <= UBound(varArray1, 1)
        r = r + 1
        c = LBound(varArray, 2) - 1
        For j = LBound(varArray1, 2) To UBound(varArray1, 2)
            c = c + 1
            varArray(r, c) = varArray1(i1, j)
        Next j
        i1 = i1 + 1
    Loop
    
    Do While i2 <= UBound(varArray2, 1)
        r = r + 1
        c = LBound(varArray, 2) - 1
        For j = LBound(varArray2, 2) To UBound(varArray2, 2)
            c = c + 1
            varArray(r, c) = varArray2(i2, j)
        Next j
        i2 = i2 + 1
    Loop
    MergeSort_Merge = varArray
End Function

Private Function MergeSort_DimCount(varArray As Variant, Optional lngRows As Long = 0, Optional lngCols As Long = 0, Optional lngZ As Long = 0) As Long
' updated 2019-05-16 by OPE
' returns the count of array dimensions in varArray
' returns -1 if varArray is not an array variable
' returns 0 if varArray is an undimensioned array variable
' lngRows: returns the count of items in the first array dimension
' lngCols: returns the count of items in the second array dimension
' lngZ: returns the count of items in the third array dimension
Dim blnIsArray As Boolean, d As Long
    MergeSort_DimCount = -1: lngRows = 0: lngCols = 0: lngZ = 0
    If Not IsArray(varArray) Then Exit Function ' not an array variable
    
    d = 0
    Err.Clear
    On Error Resume Next ' ignore error for unallocated array dimensions
    Do While IsNumeric(UBound(varArray, d + 1))
        If Err.Number = 0 Then
            d = d + 1
        Else
            Exit Do
        End If
    Loop
    If d > 0 Then
        lngRows = UBound(varArray, 1) - LBound(varArray, 1) + 1
        lngCols = UBound(varArray, 2) - LBound(varArray, 2) + 1
        lngZ = UBound(varArray, 3) - LBound(varArray, 3) + 1
    End If
    On Error GoTo 0
    MergeSort_DimCount = d
End Function

Here are some of the options you can use to sort data in Excel using VBA:
Stable sort methods:
RangeSort, TableSort, BubbleSort, MergeSort and the SORT worksheet function are stable sort methods:
Items with equal sort keys are returned in the same order in the sorted result as they had before being sorted.

QuickSort and ShellSort are not stable sort methods and you would normally not want to use these with two-dimensional arrays.

See this post if you need information about how to read from and write to worksheet cells using array variables.