我已经定义了以下数组Dim myArray(10,5) as Long,并希望对其进行排序。最好的方法是什么?

我将需要处理很多数据,例如1000 x 5矩阵。它主要包含数字和日期,需要根据特定列进行排序

最佳答案

这是VBA的多列和单列QuickSort,它是由Jim Rech在Usenet上发布的代码示例修改而成的。

笔记:

您会注意到,我在网络上进行的防御性代码比在大多数代码示例中看到的要多得多:这是一个Excel论坛,您必须预期null和空值...或者如果您的源数组来自(例如)第三方实时市场数据源,则嵌套数组和数组中的对象。

空值和无效项目将发送到列表的末尾。

您的电话将是:

 QuickSort MyArray,,,2
...Passing '2' as the column to sort on and excluding the optional parameters that pass the upper and lower bounds of the search domain.

[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


...以及单列数组版本:

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


我曾经将BubbleSort用于此类操作,但是在数组超过1024行之后,它会严重放慢速度。我包含以下代码供您参考:请注意,我没有提供ArrayDimensions的源代码,因此除非您对其进行重构-或将其拆分为“ Array”和“ vector”版本,否则不会为您编译。



Public Sub BubbleSort(ByRef InputArray,可选SortColumn as Integer = 0,可选Descending as Boolean = False)
'对一维或二维数组进行排序。


Dim iFirstRow作为整数
Dim iLastRow作为整数
Dim iFirstCol作为整数
Dim iLastCol作为整数
昏暗的整数
Dim j作为整数
Dim k作为整数
Dim varTemp作为变体
昏暗的OutputArray作为变体

Dim iDimensions作为整数



iDimensions = ArrayDimensions(InputArray)

选择案例iDimensions
情况1

iFirstRow = LBound(输入数组)
iLastRow = UBound(InputArray)

对于i = iFirstRow到iLastRow-1
对于j = i + 1到iLastRow
如果InputArray(i)> InputArray(j),则
varTemp = InputArray(j)
InputArray(j)= InputArray(i)
InputArray(i)= varTemp
万一
下一个j
接下来我

情况二

iFirstRow = LBound(InputArray,1)
iLastRow = UBound(InputArray,1)

iFirstCol = LBound(InputArray,2)
iLastCol = UBound(InputArray,2)

如果SortColumn InputArray(j,SortColumn)然后
对于k = iFirstCol到iLastCol
varTemp = InputArray(j,k)
InputArray(j,k)= InputArray(i,k)
InputArray(i,k)= varTemp
下一个k
万一
下一个j
接下来我

结束选择


如果下降则

OutputArray = InputArray

对于i = LBound(InputArray,1)到UBound(InputArray,1)

k = 1 + UBound(InputArray,1)-i
对于j = LBound(InputArray,2)到UBound(InputArray,2)
InputArray(i,j)= OutputArray(k,j)
下一个j
接下来我

擦除OutputArray

万一


结束子




该答案可能在您需要时解决您的问题时有点晚了,但是其他人在Google上找到类似问题的答案时就会选择它。

07-24 09:47
查看更多