Question

7年前，Sorting a multidimensionnal array in VBA的@NigelHeffernan发布了针对多维数组的QuickSort的非常快速的VBA实现。

令我感到羞耻的是，我看不到如何将他的升序排序转换为降序排序。 “显然”只是扭转了一些不平等现象，但是我没有解决这一问题。 Nigel的代码粘贴在下面：

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

Answer 1

对2D数组进行排序要比1D数组花费更长的时间，特别是在列数很大的情况下，但是，只要行数小于100k，列数为3-5，就可以解决此问题1秒是相当不错的，当然，性能取决于许多因素，包括但不限于CPU，内存，32位/ 64位Excel，数组的未排序程度等。

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

在VBA中对多维数组进行排序-降序版本

1 个答案: