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

JJWpalawan · Mar 19th 2022

20-mar-22

Thanks, this is going to very helpful in a few applications that I can think of.

I have a large array of strings (about 5m) that look like this, where it does not seem to work:

C1-1120-1840014659568-C21635-1, F11-719-3520015286261-208049-70, C12-1002-2260013005920-C20842-1,... etc

I pass these in a variant array but it comes back not properly sorted. I need to sort the 2-d array version of this so that I can employ binary searches.

jjw

**royUK** · Mar 20th 2022

Welcome to the Forum

Please start your own post. Posting in another member's Thread is known as hijacking and is not allowed here. By all means add a link to a Thread that may be related to your question.

VBA Merge sort

royUK Mar 20th 2022

Participate now!

Share

Users Viewing This Thread