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

Question

我已经定义了以下数组Dim myArray(10,5) as Long并且想对其进行排序。什么是最好的方法来做到这一点？

我需要处理大量数据，例如1000 x 5矩阵。它主要包含数字和日期，需要根据特定的列进行排序

Answer 1

下面是VBA的多列和单列QuickSort，由Jim Rech在Usenet上发布的代码示例进行了修改。

注：

你会发现，我做了很多更编码的防守比你在大部分的代码示例看到那里的网站：这是一个Excel论坛，和你”我们已经预测了空值和空值......或者如果源数组来自（比方说）第三方实时市场数据源，则可以在数组中嵌套数组和对象。

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

您的电话将为：

 QuickSort MyArray,,,2

...传递'2'作为列排序并排除通过搜索域上下限的可选参数。

[编辑] - 修复了<代码>代码中奇怪的格式故障，这些代码在代码注释中似乎存在超链接问题。

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

我用冒泡了这种事情，但它会减慢，严重时，数组超过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元素数组。

对于排序算法本身，我会使用普通的ol'Insertion Sort。 1000个项目实际上并不那么大，并且您可能不会注意到插入排序和快速排序之间的差异，只要我们确保每个交换不会太慢。如果你使用快速排序，你需要仔细编码以确保你的堆栈空间不会用完，但这很复杂，并且快速排序已经够棘手了。

因此，假如你使用的UDT的数组，并假设UDT包含通过字段5名为Field变种，并假设我们要排序字段2（例如），那么代码可能是这个样子......

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 

Answer 3

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

1. 添加白纸
2. 您的阵列下载到片
3. 添加排序字段
4. 应用排序
5. 重新上传的纸张数据返回到您的阵列将是相同的尺寸
6. 删除片

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

Answer 4

我打算向Steve的方法提供一些不同的代码。

所有关于效率的有效观点，但要坦率地说..当我在寻找解决方案时，我可能不在乎效率。它的VBA ......我把它当作应得的。

你想排序一个二维数组。简单简单的脏简单插入排序，它将接受一个可变大小的数组并对选定的列进行排序。

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 

Answer 5

在我看来是快速排序上面的代码无法处理的空间。我有一个数组和空格的数组。当我对这个数组进行排序时，带有空格的记录在带有数字的记录之间混合起来。我花了很多时间才发现，所以当你使用这段代码时，记住它很重要。

最好， 马塞尔

Answer 6

对于它的价值（我不能在这一点上显示的代码......让我看看，如果我可以编辑发布），我创建的自定义对象的数组（所以每个属性都随其排列的元素一起提供），填充一组单元格，然后使用excel排序函数通过vba对列进行排序。我确定这可能是一种更有效的排序方式，而不是将它输出到单元格中，我还没有弄明白。这实际上帮了我很多忙，因为当我需要添加一个维度时，我只是为该数组的下一个维度添加了let和get属性。