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

Public Sub BubbleSort(ByRef InputArray, Optional SortColumn As Integer = 0, Optional Descending As Boolean = False)' 对一维或二维数组进行排序.将 iFirstRow 调暗为整数将 iLastRow 调暗为整数将 iFirstCol 调暗为整数将 iLastCol 调暗为整数Dim i 作为整数将 j 调暗为整数将 k 调暗为整数Dim varTemp 作为变体Dim OutputArray 作为变体将 iDimensions 调暗为整数iDimensions = ArrayDimensions(InputArray)选择案例 iDimensions情况1iFirstRow = LBound(InputArray)iLastRow = UBound(InputArray)对于 i = iFirstRow 到 iLastRow - 1对于 j = i + 1 到 iLastRow如果 InputArray(i) > InputArray(j) 那么varTemp = InputArray(j)输入数组(j) = 输入数组(i)InputArray(i) = varTemp万一下一个接下来我案例二iFirstRow = LBound(InputArray, 1)iLastRow = UBound(InputArray, 1)iFirstCol = LBound(InputArray, 2)iLastCol = UBound(InputArray, 2)如果 SortColumn InputArray(j, SortColumn) 那么对于 k = iFirstCol 到 iLastColvarTemp = InputArray(j, k)InputArray(j, k) = InputArray(i, k)InputArray(i, k) = varTemp下一个万一下一个接下来我结束选择如果下降 那么输出数组 = 输入数组对于 i = LBound(InputArray, 1) 到 UBound(InputArray, 1)k = 1 + UBound(InputArray, 1) - i对于 j = LBound(InputArray, 2) 到 UBound(InputArray, 2)InputArray(i, j) = OutputArray(k, j)下一个接下来我擦除输出数组万一结束子这个答案可能在您需要时解决您的问题来得有点晚，但其他人在 Google 搜索类似问题的答案时会选择它.I have defined the following Array Dim myArray(10,5) as Long and would like to sort it. What would be the best method to do that?I will need to handle a lot of data like a 1000 x 5 Matrix. It contains mainly numbers and dates and need to sort it according to a certain column 解决方案 Here's a multi-column and a single-column QuickSort for VBA, modified from a code sample posted by Jim Rech on Usenet.Notes:You'll notice that I do a lot more defensive coding than you'll see in most of the code samples out there on the web: this is an Excel forum, and you've got to anticipate nulls and empty values... Or nested arrays and objects in arrays if your source array comes from (say) a third-party realtime market data source.Empty values and invalid items are sent to the end of the list.To sort multi-column arrays, your call will be: QuickSortArray 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.Sorting single-column arrays (vectors), instead use:QuickSortVector Myarray Here too excluding the optional parameters.[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... And the single-column array version: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 SubI used to use BubbleSort for this kind of thing, but it slows down, severely, after the array exceeds 1024 rows. I include the code below for your reference: please note that I haven't provided source code for ArrayDimensions, so this will not compile for you unless you refactor it - or split it out into 'Array' and 'vector' versions.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 IntegerDim iLastRow As IntegerDim iFirstCol As IntegerDim iLastCol As IntegerDim i As IntegerDim j As IntegerDim k As IntegerDim varTemp As VariantDim OutputArray As VariantDim iDimensions As IntegeriDimensions = 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 IfEnd SubThis answer may have arrived a bit late to solve your problem when you needed to, but other people will pick it up when they Google for answers for similar problems. 这篇关于在 VBA 中对多维数组进行排序的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！