VBA Merge sort

trunten · Jul 23rd 2019

I don't know if this will help anybody, nor can I be sure this code is bullet proof, but what I can say is that I use it an awful lot to quickly sort arrays in VBA and I haven't broken it yet. Could be useful?
Nb. this mutates the original array so make a copy of your array first if you want one with the original order in place.

Code

'Sorts a one or two dimensional array.
'2 dimensional arrays can have their sort keys specified by passing
'the appropriate column number(s) as the sortKeys parameter.
'Function passes a reference so will mutate your original array.
'If this is not desirable you must pass a copy.
'
'Example uses:
' sortArray myArray - One-dimensional array
' sortArray myArray, 2 - Two-dimensional array, single sort key
' sortArray myArray, Array(2,3,1) - Two-dimensional array, multiple sort keys
' sortArray myArray, Array(2,3,1), True - Two-dimensional array, multiple sort keys with headers preserved
Function UTIL_sortArray(ByRef arr As Variant, Optional ByRef sortKeys As Variant = Null, Optional ByVal hasHeaders As Boolean = False)
Dim mid As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long
Dim y As Long
Dim sortMode As Long
Dim arr1
Dim arr2
Dim head
Dim tmp
If UBound(arr) - LBound(arr) = 0 Then Exit Function
On Error Resume Next
i = UBound(arr, 2)
If Err.Number <> 0 Then
sortMode = 1 'Not a 2D array
If hasHeaders Then
ReDim tmp(LBound(arr) To UBound(arr) - 1)
ReDim head(1 To 1)
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then
head(1) = arr(LBound(arr))
Else
tmp(i - 1) = arr(i)
End If
Next i
arr = tmp
End If
Else
sortMode = 2
If hasHeaders Then
ReDim tmp(LBound(arr) To (UBound(arr) - 1), LBound(arr, 2) To UBound(arr, 2))
ReDim head(1 To 1, LBound(arr, 2) To UBound(arr, 2))
For i = LBound(arr) To UBound(arr)
For j = LBound(arr, 2) To UBound(arr, 2)
If i = LBound(arr) Then
head(1, j) = arr(LBound(arr), j)
Else
tmp(i - 1, j) = arr(i, j)
End If
Next j
Next i
arr = tmp
End If
End If
On Error GoTo 0
If IsNumeric(sortKeys) Then
sortKeys = Array(CLng(sortKeys))
ElseIf IsNull(sortKeys) Then
sortKeys = Array(LBound(arr))
End If
y = LBound(sortKeys)
mid = Int((UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) / 2)
If mid < LBound(arr) Then mid = LBound(arr)
If sortMode = 1 Then
ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0))
ReDim arr2(LBound(arr) To UBound(arr) - mid)
j = LBound(arr)
For i = LBound(arr1) To UBound(arr1)
arr1(i) = arr(j)
j = j + 1
Next i
For i = LBound(arr2) To UBound(arr2)
arr2(i) = arr(j)
j = j + 1
Next i
ElseIf sortMode = 2 Then
ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0), LBound(arr, 2) To UBound(arr, 2))
ReDim arr2(LBound(arr) To UBound(arr) - mid, LBound(arr, 2) To UBound(arr, 2))
j = LBound(arr)
For i = LBound(arr1) To UBound(arr1)
For k = LBound(arr1, 2) To UBound(arr1, 2)
arr1(i, k) = arr(j, k)
Next k
j = j + 1
Next i
For i = LBound(arr2) To UBound(arr2)
For k = LBound(arr2, 2) To UBound(arr2, 2)
arr2(i, k) = arr(j, k)
Next k
j = j + 1
Next i
End If
UTIL_sortArray arr1, sortKeys 'I call myself!!!
UTIL_sortArray arr2, sortKeys 'I call myself again!!!
i = LBound(arr)
j = LBound(arr1)
k = LBound(arr2)
If sortMode = 1 Then
While j <= UBound(arr1) And k <= UBound(arr2)
If arr1(j) <= arr2(k) Then
arr(i) = arr1(j)
j = j + 1
Else
arr(i) = arr2(k)
k = k + 1
End If
i = i + 1
Wend
While j <= UBound(arr1)
arr(i) = arr1(j)
j = j + 1
i = i + 1
Wend
While k <= UBound(arr2)
arr(i) = arr2(k)
k = k + 1
i = i + 1
Wend
ElseIf sortMode = 2 Then
While j <= UBound(arr1) And k <= UBound(arr2)
If arr1(j, sortKeys(y)) < arr2(k, sortKeys(y)) _
Or (arr1(j, sortKeys(y)) = arr2(k, sortKeys(y)) And UBound(sortKeys) = y) Then
For x = LBound(arr1, 2) To UBound(arr1, 2)
arr(i, x) = arr1(j, x)
Next x
j = j + 1
y = LBound(sortKeys)
ElseIf arr1(j, sortKeys(y)) > arr2(k, sortKeys(y)) Then
For x = LBound(arr2, 2) To UBound(arr2, 2)
arr(i, x) = arr2(k, x)
Next x
k = k + 1
y = LBound(sortKeys)
Else
i = i - 1
y = y + 1
End If
i = i + 1
Wend
While j <= UBound(arr1)
For x = LBound(arr1, 2) To UBound(arr1, 2)
arr(i, x) = arr1(j, x)
Next x
j = j + 1
i = i + 1
Wend
While k <= UBound(arr2)
For x = LBound(arr2, 2) To UBound(arr2, 2)
arr(i, x) = arr2(k, x)
Next x
k = k + 1
i = i + 1
Wend
End If
If hasHeaders Then
If sortMode = 1 Then
'1d
ReDim tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(LBound(tmp)) = head(1)
For i = LBound(arr) To UBound(arr)
tmp(i + 1) = arr(i)
Next i
Else
'2d
ReDim tmp(LBound(tmp) To UBound(tmp) + 1, LBound(tmp, 2) To UBound(tmp, 2))
For i = LBound(tmp) To UBound(tmp)
For j = LBound(tmp, 2) To UBound(tmp, 2)
If i = LBound(tmp) Then
tmp(i, j) = head(1, j)
Else
tmp(i, j) = arr(i - 1, j)
End If
Next
Next i
End If
arr = tmp
End If
End Function

Display More

**KjBox** · Jul 25th 2019

Neat code, thanks

trunten · Jul 25th 2019

Cheers KjBox. I find it useful at least! :grin:

**Ger Plante** · Aug 1st 2019

Hmmmm... wish I had seen this yesterday... LOL. I’ll try it out later.

**Ger Plante** · Aug 6th 2019

Awesome sauce... very very quick for me on a 2D x 1 column sort with numbers. over 40k rows.. suggestion for improvement... add another optional parameter for ascending or descending... not sure how badly that would screw up the code. Or maybe include instructions to convert between one and the other. I guess its a case of changing all < with > ? Thanks mate.

Ger

trunten · Aug 9th 2019

That's actually a very good idea! I have a reverse array function which I've always used when I wanted to sort in reverse, but it makes so much more sense to have an ascending/descending flag. I'll get on it!

trunten · Aug 9th 2019

There is definitely a more efficient way of doing this, but here's a quick and dirty version with a descending flag as the last optional argument to sort an array in descending order. Just set it to true to take effect.

Code

'Sorts a one or two dimensional array.
'2 dimensional arrays can have their sort keys specified by passing
'the appropriate column number(s) as the sortKeys parameter.
'Function passes a reference so will mutate your original array.
'If this is not desirable you must pass a copy.
'
'Example uses:
' sortArray myArray - One-dimensional array
' sortArray myArray, 2 - Two-dimensional array, single sort key
' sortArray myArray, Array(2,3,1) - Two-dimensional array, multiple sort keys
' sortArray myArray, Array(2,3,1), True - Two-dimensional array, multiple sort keys with headers preserved
Function UTIL_sortArray(ByRef arr As Variant, Optional ByRef sortKeys As Variant = Null, Optional ByVal hasHeaders As Boolean = False, Optional ByVal descending As Boolean = False)
Dim mid As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long
Dim y As Long
Dim sortMode As Long
Dim arr1
Dim arr2
Dim head
Dim tmp
If UBound(arr) - LBound(arr) = 0 Then Exit Function
On Error Resume Next
i = UBound(arr, 2)
If Err.Number <> 0 Then
sortMode = 1 'Not a 2D array
If hasHeaders Then
ReDim tmp(LBound(arr) To UBound(arr) - 1)
ReDim head(1 To 1)
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then
head(1) = arr(LBound(arr))
Else
tmp(i - 1) = arr(i)
End If
Next i
arr = tmp
End If
Else
sortMode = 2
If hasHeaders Then
ReDim tmp(LBound(arr) To (UBound(arr) - 1), LBound(arr, 2) To UBound(arr, 2))
ReDim head(1 To 1, LBound(arr, 2) To UBound(arr, 2))
For i = LBound(arr) To UBound(arr)
For j = LBound(arr, 2) To UBound(arr, 2)
If i = LBound(arr) Then
head(1, j) = arr(LBound(arr), j)
Else
tmp(i - 1, j) = arr(i, j)
End If
Next j
Next i
arr = tmp
End If
End If
On Error GoTo 0
If IsNumeric(sortKeys) Then
sortKeys = Array(CLng(sortKeys))
ElseIf IsNull(sortKeys) Then
sortKeys = Array(LBound(arr))
End If
y = LBound(sortKeys)
mid = Int((UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) / 2)
If mid < LBound(arr) Then mid = LBound(arr)
If sortMode = 1 Then
ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0))
ReDim arr2(LBound(arr) To UBound(arr) - mid)
j = LBound(arr)
For i = LBound(arr1) To UBound(arr1)
arr1(i) = arr(j)
j = j + 1
Next i
For i = LBound(arr2) To UBound(arr2)
arr2(i) = arr(j)
j = j + 1
Next i
ElseIf sortMode = 2 Then
ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0), LBound(arr, 2) To UBound(arr, 2))
ReDim arr2(LBound(arr) To UBound(arr) - mid, LBound(arr, 2) To UBound(arr, 2))
j = LBound(arr)
For i = LBound(arr1) To UBound(arr1)
For k = LBound(arr1, 2) To UBound(arr1, 2)
arr1(i, k) = arr(j, k)
Next k
j = j + 1
Next i
For i = LBound(arr2) To UBound(arr2)
For k = LBound(arr2, 2) To UBound(arr2, 2)
arr2(i, k) = arr(j, k)
Next k
j = j + 1
Next i
End If
UTIL_sortArray arr1, sortKeys 'I call myself!!!
UTIL_sortArray arr2, sortKeys 'I call myself again!!!
i = LBound(arr)
j = LBound(arr1)
k = LBound(arr2)
If sortMode = 1 Then
While j <= UBound(arr1) And k <= UBound(arr2)
If arr1(j) <= arr2(k) Then
arr(i) = arr1(j)
j = j + 1
Else
arr(i) = arr2(k)
k = k + 1
End If
i = i + 1
Wend
While j <= UBound(arr1)
arr(i) = arr1(j)
j = j + 1
i = i + 1
Wend
While k <= UBound(arr2)
arr(i) = arr2(k)
k = k + 1
i = i + 1
Wend
ElseIf sortMode = 2 Then
While j <= UBound(arr1) And k <= UBound(arr2)
If arr1(j, sortKeys(y)) < arr2(k, sortKeys(y)) _
Or (arr1(j, sortKeys(y)) = arr2(k, sortKeys(y)) And UBound(sortKeys) = y) Then
For x = LBound(arr1, 2) To UBound(arr1, 2)
arr(i, x) = arr1(j, x)
Next x
j = j + 1
y = LBound(sortKeys)
ElseIf arr1(j, sortKeys(y)) > arr2(k, sortKeys(y)) Then
For x = LBound(arr2, 2) To UBound(arr2, 2)
arr(i, x) = arr2(k, x)
Next x
k = k + 1
y = LBound(sortKeys)
Else
i = i - 1
y = y + 1
End If
i = i + 1
Wend
While j <= UBound(arr1)
For x = LBound(arr1, 2) To UBound(arr1, 2)
arr(i, x) = arr1(j, x)
Next x
j = j + 1
i = i + 1
Wend
While k <= UBound(arr2)
For x = LBound(arr2, 2) To UBound(arr2, 2)
arr(i, x) = arr2(k, x)
Next x
k = k + 1
i = i + 1
Wend
End If
If descending And (UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) > 1 Then
If sortMode = 1 Then
ReDim tmp(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
tmp(UBound(tmp) - (i - LBound(arr))) = arr(i)
Next i
ElseIf sortMode = 2 Then
ReDim tmp(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
For i = LBound(arr) To UBound(arr)
For j = LBound(arr, 2) To UBound(arr, 2)
tmp(UBound(tmp) - (i - LBound(arr)), j) = arr(i, j)
Next j
Next i
End If
arr = tmp
End If
If hasHeaders Then
If sortMode = 1 Then
'1d
ReDim tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(LBound(tmp)) = head(1)
For i = LBound(arr) To UBound(arr)
tmp(i + 1) = arr(i)
Next i
Else
'2d
ReDim tmp(LBound(tmp) To UBound(tmp) + 1, LBound(tmp, 2) To UBound(tmp, 2))
For i = LBound(tmp) To UBound(tmp)
For j = LBound(tmp, 2) To UBound(tmp, 2)
If i = LBound(tmp) Then
tmp(i, j) = head(1, j)
Else
tmp(i, j) = arr(i - 1, j)
End If
Next
Next i
End If
arr = tmp
End If
End Function

Display More

trunten · Mar 4th 2020

Made some massive changes on this to try and make it slightly more intelligent.

There is now an optional flag for ascending or descending sorts (unfortunately this is still global as I haven't had time to elegantly do it on a per sort key basis) and I've also fixed a bug if an array contained objects rather than just simple variable types. I've also changed the way the algorithm treats numbers within a text string so "10 Blah" would now sort after "2 Blah" (see example Sub below for what I mean).

Anyway, here's the updated sort code: sortArray.txt

And heres a little demo of what I mean about how Strings containing numbers are handled (you can use the autofilter to see what the default sort would have been vs. what the sort code does):

Code

Sub smartNumberSort()
Dim a, i&
ReDim a(1 To 500)
a(1) = "Key"
For i = 2 To UBound(a)
a(i) = Chr(Int((25 * Rnd) + 65)) & " " & Int((100 * Rnd) + 1)
Next i
sortArray a, hasHeaders:=True ', sortDirection:=xlDescending 'Uncomment to see reverse sort
ActiveSheet.UsedRange.ClearContents
With Range("a1").Resize(UBound(a))
.Value = Application.Transpose(a)
.AutoFilter
End With
End Sub

Display More

victorjagu · Mar 20th 2020

This is simply amazing, it helps me a lot. Thank you very much for sharing!!!

Can I ask if it's possible to move the blank items in the 2D-array ("") to the end instead of the very beginning?

Either way, thank you for this great job!!!

Sergeij_Molotow · Apr 20th 2020

Hey trunten,

I've humbled over your very useful solution (Thank you!) and I may suggest to you, that you can indicate the sortorder by using negative/positive values within the sortkeys array. For example, if there is an twodimensional array with 4 columns, the user may give the parameter like array(3,-2,1), which means that the columns 3 and 1 will be ascending sorted and column 2 will be descending. I've done this before in a completely different case, but I thought it might be a nice way to solve this.

Unfortunately I couldn't figure out, where in your code you iterate through the columns, so I can't make a code example (I'm non professional, just learning by doing).

Excuse my English, best regards from good old germany,

Sergeij

trunten · Apr 24th 2020

I like the idea, but with a zero based array there would be no way to discern ascending or descending on index 0. Food for thought though

Share