Sorting data using VBA: Merge Sort
2020-06-14 Sorting 0 179
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.