在 VBA 中对多维数组进行排序 [英] Sorting a multidimensionnal array in VBA
问题描述
我已将以下数组 Dim myArray(10,5) 定义为 Long 并希望对其进行排序.这样做的最佳方法是什么?
我需要处理大量数据，例如 1000 x 5 矩阵.主要包含数字和日期，需要按照某一列进行排序
这是 VBA 的多列和单列 QuickSort，修改自 Jim Rech 在 Usenet 上发布的代码示例.
注意事项:
您会注意到，与您在网络上的大多数代码示例中看到的相比，我进行了很多的防御性编码:这是一个 Excel 论坛，您可以预测空值和空值...或者嵌套数组和数组中的对象，如果您的源数组来自(例如)第三方实时市场数据源.
空值和无效项被发送到列表的末尾.
要对多列数组进行排序，您的调用将是:
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)出错时继续下一步'对二维数组进行排序' SampleUsage:按第 3 列的内容对 arrData 进行排序'' QuickSortArray arrData, , , 3''由 Jim Rech 于 98 年 10 月 20 日发布.'修改，奈杰尔·赫弗南:' ' 转义失败与空变体的比较' ' 防御性编码:检查输入昏暗的我Dim j As LongDim varMid 作为变体Dim arrRowTemp 作为变体Dim lngColTemp 尽可能长如果 IsEmpty(SortArray) 那么退出子万一如果 InStr(TypeName(SortArray), "()") <1 然后 'IsArray() 有点坏:在类型名称中查找括号退出子万一如果 lngMin = -1 那么lngMin = LBound(SortArray, 1)万一如果 lngMax = -1 那么lngMax = UBound(SortArray, 1)万一If lngMin >= lngMax Then ' 不需要排序退出子万一i = lngMinj = lngMaxvarMid = 空varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)' 我们将 'Empty' 和无效的数据项发送到列表的末尾:If IsObject(varMid) Then ' 注意我们不检查 isObject(SortArray(n)) - varMid *可能* 选择一个有效的默认成员或属性i = lngMaxj = lngMinElseIf IsEmpty(varMid) 然后i = lngMaxj = lngMinElseIf IsNull(varMid) 然后i = lngMaxj = lngMinElseIf varMid = "";然后i = lngMaxj = lngMinElseIf VarType(varMid) = vbError Theni = lngMaxj = lngMinElseIf VarType(varMid) >17 那么i = lngMaxj = lngMin万一当 i <= j虽然 SortArray(i, lngColumn) 明明j = j - 1温德如果 i <= j 那么'交换行ReDim arrRowTemp(LBound(SortArray, 2) 到 UBound(SortArray, 2))对于 lngColTemp = LBound(SortArray, 2) 到 UBound(SortArray, 2)arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)SortArray(i, lngColTemp) = SortArray(j, lngColTemp)SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)下一个 lngColTemp擦除 arrRowTemp我 = 我 + 1j = j - 1万一温德如果 (lngMin ...以及单列数组版本:
公共子QuickSortVector(ByRef SortArray As Variant，可选lngMin As Long = -1，可选lngMax As Long = -1)出错时继续下一步'对一维数组进行排序' SampleUsage: 排序 arrData'' QuickSortVector arrData'' 最初由 Jim Rech 于 98 年 10 月 20 日发表 Excel.Programming' 修改，奈杰尔·赫弗南:' ' 与数组中的空变体进行比较时转义失败' ' 防御性编码:检查输入昏暗的我Dim j As LongDim varMid 作为变体Dim varX 作为变体如果 IsEmpty(SortArray) 那么退出子万一如果 InStr(TypeName(SortArray), "()") <1 然后 'IsArray() 有点坏:在类型名称中查找括号退出子万一如果 lngMin = -1 那么lngMin = LBound(SortArray)万一如果 lngMax = -1 那么lngMax = UBound(SortArray)万一If lngMin >= lngMax Then ' 不需要排序退出子万一i = lngMinj = lngMaxvarMid = 空varMid = SortArray((lngMin + lngMax) \ 2)' 我们将 'Empty' 和无效的数据项发送到列表的末尾:If IsObject(varMid) Then ' 请注意，我们不检查 isObject(SortArray(n)) - varMid *可能* 选择默认成员或属性i = lngMaxj = lngMinElseIf IsEmpty(varMid) 然后i = lngMaxj = lngMinElseIf IsNull(varMid) 然后i = lngMaxj = lngMinElseIf varMid = "";然后i = lngMaxj = lngMinElseIf VarType(varMid) = vbError Theni = lngMaxj = lngMinElseIf VarType(varMid) >17 那么i = lngMaxj = lngMin万一当 i <= j虽然 SortArray(i) 明明j = j - 1温德如果 i <= j 那么' 交换项目varX = SortArray(i)SortArray(i) = SortArray(j)SortArray(j) = varX我 = 我 + 1j = j - 1万一温德如果 (lngMin 我曾经将 BubbleSort 用于这种事情，但在数组超过 1024 行后，它会严重变慢.我提供了以下代码供您参考:请注意，我没有提供 ArrayDimensions 的源代码，因此除非您对其进行重构或将其拆分为Array"和vector"版本，否则它不会为您编译.<前>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 Sub
I 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 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
This 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 中对多维数组进行排序的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
