在VBA中对多维数组进行排序

Question

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

我将需要处理大量数据,如1000 x 5矩阵.它主要包含数字和日期,需要根据某列进行排序

Answer 1

这是一个多列和单列QuickSort for VBA,修改自Jim Rech在Usenet上发布的代码示例.

笔记:

你会发现,我做了很多更具防御性的编码比你在大部分的代码示例看到那里的网站:这是一个Excel论坛,你必须事先估计到空和空值...或者如果源数组来自(比方说)第三方实时市场数据源,则数组中的嵌套数组和对象.

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

您的电话将是:

 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, Optional SortColumn As Integer = 0, Optional Descending As Boolean = False)
' Sort a 1- or 2-Dimensional array.


Dim iFirstRow   As Integer
Dim iLastRow    As Integer
Dim iFirstCol   As Integer
Dim iLastCol    As Integer
Dim i           As Integer
Dim j           As Integer
Dim k           As Integer
Dim varTemp     As Variant
Dim OutputArray As Variant

Dim iDimensions As Integer



iDimensions = 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 If


End Sub

在你需要的时候,这个答案可能已经到了解决你的问题的时间有点迟了,但是其他人会在谷歌寻找类似问题的答案时捡到它.

Answer 2

困难的部分是VBA没有提供直接的方式来交换2D数组中的行.对于每个交换,您将不得不循环5个元素并交换每个元素,这将是非常低效的.

我猜测2D阵列确实不是你应该使用的.每列是否都有特定含义？如果是这样,您是否应该使用用户定义类型的数组,或者是作为类模块实例的对象数组？即使5列没有特定含义,您仍然可以执行此操作,但将UDT或类模块定义为只有一个5元素数组的成员.

对于排序算法本身,我会使用普通的'插入排序.1000项实际上并没有那么大,你可能不会注意到插入排序和快速排序之间的区别,只要我们确保每次交换都不会太慢.如果你做使用快速排序,你需要仔细编写代码的时候确保你不会用完堆栈空间,这是可以做到的,但它的复杂,快速排序是够棘手了.

因此,假设您使用UDT数组,并假设UDT包含名为Field1到Field5的变体,并假设我们要对Field2进行排序(例如),那么代码可能看起来像这样......

Type MyType
    Field1 As Variant
    Field2 As Variant
    Field3 As Variant
    Field4 As Variant
    Field5 As Variant
End Type

Sub 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 I
End Sub