在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屬性。