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

时间：2011-02-02 10:18:38

标签： arrays vba sorting

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

我需要处理大量数据，如1000 x 5 Matrix。它主要包含数字和日期，需要根据某列进行排序

10 个答案:

答案 0 :(得分：24)

这是一个用于VBA的多列和单列QuickSort，根据Jim Rech在Usenet上发布的代码示例进行了修改。

注意：

你会注意到我做了一个很多更多的防御性编码，而不是你在网上的大多数代码示例中看到的：这是一个Excel论坛，你已经有了预测空值和空值...或者如果源数组来自（比方说）第三方实时市场数据源，则在数组中嵌套数组和对象。

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

您的电话将是：

 QuickSort MyArray,,,2
...传递'2'作为列，以排序和排除通过搜索域上下界的可选参数。

[已编辑] - 修复了＆lt; code＆gt;中的奇怪格式化故障。标签，似乎在代码注释中有超链接问题。

我切除的超链接是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

在您需要的时候，这个答案可能已经到了解决问题的时间有点迟了，但是其他人会在谷歌找到类似问题的答案时接听它。

答案 1 :(得分：8)

困难的部分是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

答案 2 :(得分：1)

有时最无脑的答案是最好的答案。

  1. 添加空白表
  2. 将您的阵列下载到该表
  3. 添加排序字段
  4. 应用排序
  5. 将工作表数据重新上传回您的数组，它将是相同的维度
  6. 删除工作表

    7. tadaa。不会赢得任何编程奖品，但它可以快速完成工作。

答案 3 :(得分：0)

为了它的价值（我现在无法显示代码......让我看看我是否可以编辑它来发布），我创建了一个自定义对象数组（因此每个属性都带有其中的任何一个元素排序方式），填充一组单元格，每个元素对象属性感兴趣，然后通过vba使用excel排序函数对列进行排序。我确定这可能是一种更有效的排序方式，而不是将其输出到单元格，我还没想到它。这实际上对我有很大帮助，因为当我需要添加维度时，我只是为数组的下一个维度添加了一个let和get属性。

答案 4 :(得分：0)

您可以创建一个包含2列的单独数组。第1列将是您的排序，2是其他数组中的行。按列1对此数组进行排序（仅在交换时切换两列）。然后，您可以根据需要使用2个数组来处理数据。虽然

，但巨大的数组可能会给你带来内存问题

答案 5 :(得分：0)

这是一个艰难的过程，因为它取决于许多参数，但是在分析了许多算法之后，我认为这一算法总体上具有出色的性能。在速度不是很快的机器上，我在1秒内对3列数组进行了排序，其中包含10万行。我尝试了更少的行，只是一瞬间，但是对于一百万行，我在9到26秒之间得到了不同的数据（未排序数据的百分比仍然会产生影响）。

一种用于升序的例程，另一种用于降序的排序。 iCol，这是第二个参数，是应该在其上对数组进行排序的列的索引。

Public Sub MedianThreeQuickSort1_2D_Asc(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_Asc pvarArray, iCol, plngLeft, lngLast
        If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Asc pvarArray, iCol, lngFirst, plngRight
    Else
        If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Asc pvarArray, iCol, lngFirst, plngRight
        If plngLeft < lngLast Then MedianThreeQuickSort1_2D_Asc pvarArray, iCol, plngLeft, lngLast
    End If
End Sub

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

答案 6 :(得分：0)

在对多列数组进行排序时，我不会重新排列元素。相反，我通过了另一个具有相同数量元素的数组S，并对项目1,2,3，....

进行编号

然后，我使用S中的值作为要排序的列的索引，当我需要交换元素时，我交换S中的值。

从排序返回时，如果需要，我可以根据S中的排序顺序重新排列原始数组。采用快速排序很容易做到这一点。

答案 7 :(得分：0)

我有类似的Doubles数组要排序，因此我决定编写一个本机.dll。 为了进行测试，我使用的是64位整数，因此您可以使用它对Long和ULong数组的最后一个维度进行排序。

    <DllImport("Arrayman.dll", EntryPoint:="SortLng")>
    Sub sort(ByRef Array1stItem As Long, ByRef Indices1stItem As Integer, ByVal nItemsToSort As Long)
    'Note: For sorting ULong integers, replace EntryPoint:="SortLng" with EntryPoint:="SortULng"
    End Sub

在您的示例中，您将其称为

Dim idx(5)
sort(myArray(3,0), idx(0), idx.count)

将项目从(3, 0)到(3, 5)进行排序。 最低的数字为myArray(3, idx(0))，最高的数字为myArray(3, idx(5))。

ArrayMan.dll ，更多信息和示例，on GitHub

答案 8 :(得分：-1)

在我看来，上面的QuickSort代码无法处理空格。我有一个数字和空格的数组。当我对这个数组进行排序时，带有空格的记录会在带有数字的记录之间混淆。我花了很多时间才发现，所以当你使用这段代码时，记住它可能是件好事。

最好的， 烫发

答案 9 :(得分：-1)

这是一个很好的强大代码。 出于习惯对其进行了测试。不是没有。

varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

'当（lngMin + lngMax）\ 2不是整数时，捕获错误。

'替换为

Dim row_Mid as long
row_Mid = Int((lngMin + lngMax) \ 2)
varMid = SortArray(row_Mid, lngColumn)

先生们，编写测试...

相关问题
最新问题