Sorting a multidimensionnal array in VBA

Here's a multi-column and a single-column QuickSort for VBA, modified from a code sample posted by Jim Rech on Usenet.

Notes:

You'll notice that I do a lot more defensive coding than you'll see in most of the code samples out there on the web: this is an Excel forum, and you've got to anticipate nulls and empty values... Or nested arrays and objects in arrays if your source array comes from (say) a third-party realtime market data source.

Empty values and invalid items are sent to the end of the list.

To sort multi-column arrays, your call will be:

 QuickSortArray MyArray,,,2

Sorting single-column arrays (vectors), instead use:

QuickSortVector Myarray

[EDITED] - fixed an odd formatting glitch in the <code> tags, which seem to have a problem with hyperlinks in code comments.

The Hyperlink I excised was Detecting an Array Variant in VBA.

Public Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)    On Error Resume Next    'Sort a 2-Dimensional array    ' SampleUsage: sort arrData by the contents of column 3    '    '   QuickSortArray arrData, , , 3    '    'Posted by Jim Rech 10/20/98 Excel.Programming    'Modifications, Nigel Heffernan:    '       ' Escape failed comparison with empty variant    '       ' Defensive coding: check inputs    Dim i As Long    Dim j As Long    Dim varMid As Variant    Dim arrRowTemp As Variant    Dim lngColTemp As Long    If IsEmpty(SortArray) Then        Exit Sub    End If    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name        Exit Sub    End If    If lngMin = -1 Then        lngMin = LBound(SortArray, 1)    End If    If lngMax = -1 Then        lngMax = UBound(SortArray, 1)    End If    If lngMin >= lngMax Then    ' no sorting required        Exit Sub    End If    i = lngMin    j = lngMax    varMid = Empty    varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)    ' We  send 'Empty' and invalid data items to the end of the list:    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property        i = lngMax        j = lngMin    ElseIf IsEmpty(varMid) Then        i = lngMax        j = lngMin    ElseIf IsNull(varMid) Then        i = lngMax        j = lngMin    ElseIf varMid = "" Then        i = lngMax        j = lngMin    ElseIf VarType(varMid) = vbError Then        i = lngMax        j = lngMin    ElseIf VarType(varMid) > 17 Then        i = lngMax        j = lngMin    End If    While i <= j        While SortArray(i, lngColumn) < varMid And i < lngMax            i = i + 1        Wend        While varMid < SortArray(j, lngColumn) And j > lngMin            j = j - 1        Wend        If i <= j Then            ' Swap the rows            ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))            For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)                arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)                SortArray(i, lngColTemp) = SortArray(j, lngColTemp)                SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)            Next lngColTemp            Erase arrRowTemp            i = i + 1            j = j - 1        End If    Wend    If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)    If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)    End Sub

... And the single-column array version:

Public Sub QuickSortVector(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1)    On Error Resume Next    'Sort a 1-Dimensional array    ' SampleUsage: sort arrData    '    '   QuickSortVector arrData    '    ' Originally posted by Jim Rech 10/20/98 Excel.Programming    ' Modifications, Nigel Heffernan:    '       ' Escape failed comparison with an empty variant in the array    '       ' Defensive coding: check inputs    Dim i As Long    Dim j As Long    Dim varMid As Variant    Dim varX As Variant    If IsEmpty(SortArray) Then        Exit Sub    End If    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name        Exit Sub    End If    If lngMin = -1 Then        lngMin = LBound(SortArray)    End If    If lngMax = -1 Then        lngMax = UBound(SortArray)    End If    If lngMin >= lngMax Then    ' no sorting required        Exit Sub    End If    i = lngMin    j = lngMax    varMid = Empty    varMid = SortArray((lngMin + lngMax) \ 2)    ' We  send 'Empty' and invalid data items to the end of the list:    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a default member or property        i = lngMax        j = lngMin    ElseIf IsEmpty(varMid) Then        i = lngMax        j = lngMin    ElseIf IsNull(varMid) Then        i = lngMax        j = lngMin    ElseIf varMid = "" Then        i = lngMax        j = lngMin    ElseIf VarType(varMid) = vbError Then        i = lngMax        j = lngMin    ElseIf VarType(varMid) > 17 Then        i = lngMax        j = lngMin    End If    While i <= j        While SortArray(i) < varMid And i < lngMax            i = i + 1        Wend        While varMid < SortArray(j) And j > lngMin            j = j - 1        Wend        If i <= j Then            ' Swap the item            varX = SortArray(i)            SortArray(i) = SortArray(j)            SortArray(j) = varX            i = i + 1            j = j - 1        End If    Wend    If (lngMin < j) Then Call QuickSortVector(SortArray, lngMin, j)    If (i < lngMax) Then Call QuickSortVector(SortArray, i, lngMax)End Sub

I used to use BubbleSort for this kind of thing, but it slows down, severely, after the array exceeds 1024 rows. I include the code below for your reference: please note that I haven't provided source code for ArrayDimensions, so this will not compile for you unless you refactor it - or split it out into 'Array' and 'vector' versions.

Public Sub BubbleSort(ByRef InputArray, Optional SortColumn As Integer = 0, Optional Descending As Boolean = False)' Sort a 1- or 2-Dimensional array.Dim iFirstRow   As IntegerDim iLastRow    As IntegerDim iFirstCol   As IntegerDim iLastCol    As IntegerDim i           As IntegerDim j           As IntegerDim k           As IntegerDim varTemp     As VariantDim OutputArray As VariantDim iDimensions As IntegeriDimensions = ArrayDimensions(InputArray)    Select Case iDimensions    Case 1        iFirstRow = LBound(InputArray)        iLastRow = UBound(InputArray)                For i = iFirstRow To iLastRow - 1            For j = i + 1 To iLastRow                If InputArray(i) > InputArray(j) Then                    varTemp = InputArray(j)                    InputArray(j) = InputArray(i)                    InputArray(i) = varTemp                End If            Next j        Next i            Case 2        iFirstRow = LBound(InputArray, 1)        iLastRow = UBound(InputArray, 1)                iFirstCol = LBound(InputArray, 2)        iLastCol = UBound(InputArray, 2)                If SortColumn  InputArray(j, SortColumn) Then                    For k = iFirstCol To iLastCol                        varTemp = InputArray(j, k)                        InputArray(j, k) = InputArray(i, k)                        InputArray(i, k) = varTemp                    Next k                End If            Next j        Next i    End Select            If Descending Then            OutputArray = InputArray                For i = LBound(InputArray, 1) To UBound(InputArray, 1)                    k = 1 + UBound(InputArray, 1) - i            For j = LBound(InputArray, 2) To UBound(InputArray, 2)                InputArray(i, j) = OutputArray(k, j)            Next j        Next i         Erase OutputArray            End IfEnd Sub

This answer may have arrived a bit late to solve your problem when you needed to, but other people will pick it up when they Google for answers for similar problems.

The hard part is that VBA provides no straightforward way to swap rows in a 2D array. For each swap, you're going to have to loop over 5 elements and swap each one, which will be very inefficient.

I'm guessing that a 2D array is really not what you should be using anyway though. Does each column have a specific meaning? If so, should you not be using an array of a user-defined type, or an array of objects that are instances of a class module? Even if the 5 columns don't have specific meanings, you could still do this, but define the UDT or class module to have just a single member that is a 5-element array.

For the sort algorithm itself, I would use a plain ol' Insertion Sort. 1000 items is actually not that big, and you probably won't notice the difference between an Insertion Sort and Quick Sort, so long as we've made sure that each swap will not be too slow. If you do use a Quick Sort, you'll need to code it carefully to make sure you won't run out of stack space, which can be done, but it's complicated, and Quick Sort is tricky enough already.

So assuming you use an array of UDTs, and assuming the UDT contains variants named Field1 through Field5, and assuming we want to sort on Field2 (for example), then the code might look something like this...

Type MyType    Field1 As Variant    Field2 As Variant    Field3 As Variant    Field4 As Variant    Field5 As VariantEnd TypeSub SortMyDataByField2(ByRef Data() As MyType)    Dim FirstIdx as Long, LastIdx as Long    FirstIdx = LBound(Data)    LastIdx = UBound(Data)    Dim I as Long, J as Long, Temp As MyType    For I=FirstIdx to LastIdx-1        For J=I+1 to LastIdx            If Data(I).Field2 > Data(J).Field2 Then                Temp = Data(I)                Data(I) = Data(J)                Data(J) = Temp            End If        Next J    Next IEnd Sub

sometimes the most brainless answer is the best answer.

1. add blank sheet
2. download your array to that sheet
3. add the sort fields
4. apply the sort
5. reupload the sheet data back to your array it will be the same dimension
6. delete the sheet

tadaa. wont win you any programming prizes but it gets the job done fast.