我已经定义了以下数组Dim myArray(10,5) as Long
,并希望对其进行排序。最好的方法是什么?
我将需要处理很多数据,例如1000 x 5矩阵。它主要包含数字和日期,需要根据特定列进行排序
最佳答案
这是VBA的多列和单列QuickSort,它是由Jim Rech在Usenet上发布的代码示例修改而成的。
笔记:
您会注意到,我在网络上进行的防御性代码比在大多数代码示例中看到的要多得多:这是一个Excel论坛,您必须预期null和空值...或者如果您的源数组来自(例如)第三方实时市场数据源,则嵌套数组和数组中的对象。
空值和无效项目将发送到列表的末尾。
您的电话将是:
QuickSort 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.
[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
...以及单列数组版本:
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
我曾经将BubbleSort用于此类操作,但是在数组超过1024行之后,它会严重放慢速度。我包含以下代码供您参考:请注意,我没有提供ArrayDimensions的源代码,因此除非您对其进行重构-或将其拆分为“ Array”和“ vector”版本,否则不会为您编译。
Public Sub BubbleSort(ByRef InputArray,可选SortColumn as Integer = 0,可选Descending as Boolean = False)
'对一维或二维数组进行排序。
Dim iFirstRow作为整数
Dim iLastRow作为整数
Dim iFirstCol作为整数
Dim iLastCol作为整数
昏暗的整数
Dim j作为整数
Dim k作为整数
Dim varTemp作为变体
昏暗的OutputArray作为变体
Dim iDimensions作为整数
iDimensions = ArrayDimensions(InputArray)
选择案例iDimensions
情况1
iFirstRow = LBound(输入数组)
iLastRow = UBound(InputArray)
对于i = iFirstRow到iLastRow-1
对于j = i + 1到iLastRow
如果InputArray(i)> InputArray(j),则
varTemp = InputArray(j)
InputArray(j)= InputArray(i)
InputArray(i)= varTemp
万一
下一个j
接下来我
情况二
iFirstRow = LBound(InputArray,1)
iLastRow = UBound(InputArray,1)
iFirstCol = LBound(InputArray,2)
iLastCol = UBound(InputArray,2)
如果SortColumn InputArray(j,SortColumn)然后
对于k = iFirstCol到iLastCol
varTemp = InputArray(j,k)
InputArray(j,k)= InputArray(i,k)
InputArray(i,k)= varTemp
下一个k
万一
下一个j
接下来我
结束选择
如果下降则
OutputArray = InputArray
对于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)
下一个j
接下来我
擦除OutputArray
万一
结束子
该答案可能在您需要时解决您的问题时有点晚了,但是其他人在Google上找到类似问题的答案时就会选择它。