Sorting a multi-dimensional array in VBA - descending version

Question

7 years ago @NigelHeffernan at Sorting a multidimensionnal array in VBA posted a very fast VBA implementation of QuickSort for multi-dimensional arrays.

To my shame I can't see how to turn his ascending sort into a descending sort. "Obviously" one just reverses some inequalities, but I have not managed this. Nigel's code is pasted below:

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 using On Error Resume Next as first line is no good idea. It just hides all error messages but the errors still occur. You just cannot see them and therefore you cannot fix them. Remove that line and fix occurring errors. — Pᴇʜ
– Pᴇʜ, Commented Nov 5, 2018 at 16:03
@Comintern thanks - that was what I was hinting at in my question too, but I couldn't see exactly which ones to change. Based on mrexcel.com/forum/excel-questions/… I can now see that only two small changes are required: change SortArray(i, lngColumn) < varMid and varMid < SortArray(j, lngColumn). And apologies for pasting this code inline; I couldn't see how to put code in a comment rather than a question. — coolactuary
– coolactuary, Commented Nov 5, 2018 at 16:24
@Pᴇʜ Thanks and noted. Someone else's code, but puzzling that the Resume next is left there as the rest is defensive coding. Oh and thanks for moving the End Sub bit for me - I just couldn't get that to keep in the code. — coolactuary
– coolactuary, Commented Nov 5, 2018 at 16:25
On Error Resume next should be blocked as default until the student or "programmer" comprehends the consequenses of using it. — user2261597
– user2261597, Commented Nov 5, 2018 at 16:52

Ibo · Accepted Answer · 2020-08-20 00:44:54Z

Sorting a 2D array takes a lot longer than a 1D array, especially if the number of columns is large, however as long as the number of rows is under 100k and number of columns are 3-5 the job can be done around 1 second which is pretty good, of course, the performance depends on many factors including but not limited to the CPU, memory, 32-bit/64-bit Excel, how unsorted is the array, etc:

Public Sub MedianThreeQuickSort1_2D_Desc(ByRef pvarArray As Variant, _
                                        ByVal iCol As Integer, _
                                            Optional ByVal plngLeft As Long, _
                                                Optional ByVal plngRight As Long)
'Grade A+
'NOTE: recursive routine, omit plngLeft & plngRight; they are used internally during recursion
    Dim j As Integer
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim lngIndex As Long
    Dim varSwap As Variant
    Dim a As Long
    Dim b As Long
    Dim c As Long
    
    If plngRight = 0 Then
        plngLeft = LBound(pvarArray, 1)
        plngRight = UBound(pvarArray, 1)
    End If
    
    lngFirst = plngLeft
    lngLast = plngRight
    lngIndex = plngRight - plngLeft + 1
    a = Int(lngIndex * Rnd) + plngLeft
    b = Int(lngIndex * Rnd) + plngLeft
    c = Int(lngIndex * Rnd) + plngLeft
    If pvarArray(a, iCol) <= pvarArray(b, iCol) And pvarArray(b, iCol) <= pvarArray(c, iCol) Then
        lngIndex = b
    Else
        If pvarArray(b, iCol) <= pvarArray(a, iCol) And pvarArray(a, iCol) <= pvarArray(c, iCol) Then
            lngIndex = a
        Else
            lngIndex = c
        End If
    End If
    
    varMid = pvarArray(lngIndex, iCol)
    Do
        Do While pvarArray(lngFirst, iCol) > varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        
        Do While varMid > pvarArray(lngLast, iCol) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        
        If lngFirst <= lngLast Then
            For j = LBound(pvarArray, 2) To UBound(pvarArray, 2)
                varSwap = pvarArray(lngLast, j)
                pvarArray(lngLast, j) = pvarArray(lngFirst, j)
                pvarArray(lngFirst, j) = varSwap
            Next j
            
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    
    If (lngLast - plngLeft) < (plngRight - lngFirst) Then
        If plngLeft < lngLast Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, plngLeft, lngLast
        If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, lngFirst, plngRight
    Else
        If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, lngFirst, plngRight
        If plngLeft < lngLast Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, plngLeft, lngLast
    End If
End Sub

Collectives™ on Stack Overflow

Sorting a multi-dimensional array in VBA - descending version

1 Answer 1

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related