logo标签列表

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

arraysvbasorting
22

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

我将需要处理许多类似 1000 x 5 矩阵的数据。它主要包含数字和日期，需要根据某一列进行排序。

1
请参考这个问题的被接受的答案。我不确切地知道您希望如何排序，但您可以根据需要修改快速排序算法的实现。 - Cody Gray
1
嗨，BlackLabrador，我认为我们可能需要更多关于您想要在这里做什么的信息......您是想将所有50个项目排序成一个长列表，还是按“列”或“行”进行排序或以其他方式进行排序？如果您编辑您的帖子包括此类信息，则更有可能获得更多/更有用的答案。 - Simon Cowen
感谢您的评论。我会查看Cody的链接。 - BlackLabrador
9个回答
45
这是一个多列和单列的快速排序算法，适用于VBA，修改自Jim Rech在Usenet上发布的代码示例。
注意：
你会发现我比大多数网上的代码示例都做了更多的防御性编码：这是一个Excel论坛，你必须预见到null和空值...或者如果你的源数组来自第三方实时市场数据源，则可以预见到包含在数组中的嵌套数组和对象。
空值和无效项将被发送到列表的末尾。
要对多列数组进行排序，你的调用将是：
QuickSortArray MyArray,,,2
...将“2”作为要排序的列，并排除传递搜索域的上限和下限的可选参数。
而对于单列数组（向量）进行排序，则使用：
QuickSortVector Myarray
，这里也要排除可选参数。
[编辑] - 修复了<code>标记中的奇怪格式故障，似乎代码注释中的超链接存在问题。
我删除的超链接是检测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

我曾经使用冒泡排序来解决这类问题，但是当数组超过1024行时，速度会严重减慢。以下是代码供您参考：请注意，我没有提供ArrayDimensions的源代码，因此除非您对其进行重构或将其拆分为“Array”和“vector”版本，否则无法编译它。 
Public Sub BubbleSort(ByRef InputArray, Optional SortColumn As Integer = 0, Optional Descending As Boolean = False)
' 对1维或2维数组进行排序。
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
为什么QuickSortArray子程序要翻转列？结果数组是原始数组的镜像，但已排序。 - lukehawk
1
抱歉，Nile。我的数组维度反了，它在排序列而不是行。有点奇怪的一次性错误。你的代码没问题。对于混淆我感到抱歉。所以，只是为了明确，arrRowTemp上的Redim应该在while循环外面吗？因为你只需要分配一次内存，然后每次都覆盖它？ - lukehawk
1
这是一个好的解决方案，但如果您的数组是相同定义的，请不要忘记设置Option Base 1。当我对一个二维数组进行排序时，第二列（也是排序列）的一个值为零。排序完成后，第一列的值也被设置为零。我花了将近两个小时才解决这个问题。最后，在模块中设置Option Base 1后，一切都变得正常了。 - Phil
1
通过上面的代码对数组进行排序是不是永久的。因此，首先按列1对其进行排序，然后再按列2对其进行排序，将无法保留列1中相似值的顺序。它似乎总是从原始SortArray开始。有没有办法使排序变得永久（例如，将代码作为函数，将排序后的数组分配给新变量，然后对已排序的数组运行排序函数）？ - Geole
1
@Geole - 是的，它是在基于数组将会被排序、重排自身的假设上编写的；而我故意作出了一个设计决策，即不复制并创建一个新数组，以及所有相关的分配开销和加倍的内存"占用空间"问题。这就是为什么我使用带有对数组引用的子程序，而不是返回新数组的函数。如果你的代码实际需要，那么你将需要进行一些重构，并将其重新配置为一个函数，该函数采用InputArray参数（仍然通过引用！），并声明并返回一个'OutputArray'变量。 - Nigel Heffernan
显示剩余18条评论
8
困难的部分是VBA没有直接交换2D数组中行的简单方法。 对于每个交换，您将不得不循环遍历5个元素并交换每个元素，这将非常低效。
我猜2D数组实际上并不是您应该使用的东西。 每列是否具有特定含义？ 如果是这样，您不应该使用用户定义类型的数组或类模块的实例的对象数组吗？ 即使5列没有特定含义，您仍然可以这样做，但需要定义UDT或类模块仅具有一个成员，该成员是5元素数组。
对于排序算法本身，我会使用普通的插入排序。 1000个项目实际上并不算太大，您可能不会注意到插入排序和快速排序之间的区别，只要我们确保每个交换不会太慢即可。如果您使用快速排序，则需要仔细编写代码，以确保不会用尽堆栈空间，这可以完成，但已经够棘手了。
因此，假设您使用UDTs的数组，并且假设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
当然，您正在对记录向量进行排序。如果只有一些可用的库可以在“Recordset”中捕获表格数据，使用BTree进行索引，并调用编译到金属的“Sort”函数... :o) - Nigel Heffernan
4

这是一个很难的问题，因为它取决于许多参数，但在分析了许多算法后，我选择了这个在整体表现良好的算法。在我的不太快的机器上，我用1秒钟对有100k行的3列数组进行排序。我尝试了较少的行，只需一瞬间就可以完成，但对于一百万行，根据不同的数据（未排序数据的百分比）要花费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
经过数小时的搜索，我今天采用了这种方法。完美运作！太棒了。 - user68650
ibo - 是否可以修改上述过程以对数组的可选第二列进行排序？ - user68650
如果需要的话，请运行该函数两次，一次用于第一列，一次用于第二列。没有必要让这变得更加复杂。您可以对多个列进行排序。只需多次运行即可。 - Ibo
这两列应该相互依赖地排序。例如，首先按姓氏排序，保持该排序，然后按名字从A到Z排序。如果执行函数两次，则仅在上一次排序的最后一列（即名字）上进行排序。 - user68650
就像我说的那样，你应该先按照名字排序，然后再按照姓氏排序。这样可以得到一个按照姓氏排序的列表，并且在已排序的姓氏中，名字也会被排序显示。 - Ibo
2

有时候最简单的答案是最好的答案。

  1. 添加空白表格
  2. 将你的数组下载至该表格
  3. 添加排序字段
  4. 应用排序
  5. 重新上传表格数据回到你的数组中（它将保持相同的维度）
  6. 删除表格

完成。这不会赢得任何编程奖项，但可以快速完成工作。

1
我将提供与Steve的方法略有不同的一点代码。
所有有效的效率观点，但坦白地说...当我正在寻找解决方案时，我可能根本不关心效率。这是VBA...我对待它像它应得的那样。
您想要对2-d数组进行排序。简单明了的脏插入排序可以接受可变大小的数组，并在所选列上进行排序。
Sub sort_2d_array(ByRef arrayin As Variant, colid As Integer)
'theWidth = LBound(arrayin, 2) - UBound(arrayin, 2)
For i = LBound(arrayin, 1) To UBound(arrayin, 1)
    searchVar = arrayin(i, colid)
    For ii = LBound(arrayin, 1) To UBound(arrayin, 1)
        compareVar = arrayin(ii, colid)
        If (CInt(searchVar) > CInt(compareVar)) Then
            For jj = LBound(arrayin, 2) To UBound(arrayin, 2)
                larger1 = arrayin(i, jj)
                smaller1 = arrayin(ii, jj)
                arrayin(i, jj) = smaller1
                arrayin(ii, jj) = larger1
            Next jj
            i = LBound(arrayin, 1)
            searchVar = arrayin(i, colid)
        End If
        Next ii
    Next i
End Sub
4
你的讽刺话配得上一份差评。BASIC语言历史悠久，值得尊重。 - Excel Hero
0

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

0

你可以创建一个有两列的独立数组。第一列是你要排序的内容，第二列是在另一个数组中的行数。通过按第一列排序这个数组（只有在交换时才切换两列），然后你可以使用这两个数组来处理需要的数据。但是，大型数组可能会导致内存问题。

0

在对多列数组进行排序时，我不会重新排列元素。相反，我通过另一个具有相同数量元素的数组S，遍历并将项目编号为1、2、3等。

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

在从排序返回时，如果需要，我可以根据S中的排序顺序重新排列原始数组。很容易将快速排序适应于此。

0

我有一个类似的Double数组需要排序，所以我决定编写一个本地的.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，更多信息和示例可在GitHub上找到。

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接