在VBA中对数组排序的代码
在VBA中对数组排序的代码
fanjy
发布于 2023-09-21 11:40:46
发布于 2023-09-21 11:40:46
代码可运行
运行总次数：0
代码可运行
标签：VBA
这是一段非常好的代码，来自ozgrid.com，可以使用它来快速排序VBA中的数组。
代码如下：
'对一维或二维数组排序.
'二维数组可以通过传递适当的列编号作为sortKeys参数来指定其排序键.
'函数传递一个引用，因此将对原始数组进行变异.
'如果不需要，必须传递一份副本.
'
'示例使用:
' sortArray myArray - 一维数组
' sortArray myArray, 2 - 二维数组, 单个排序键
' sortArray myArray, Array(2,3,1) - 二维数组，多个排序键
Function sortArray(ByRef arr As Variant, Optional ByRef sortKeys As Variant = Null, _
Optional ByVal hasHeaders As Boolean = False, Optional sortDirection As XlSortOrder = xlAscending) As Variant
Dim mid&, i&, j&, k&, x&, y&, sortMode&, padLen&, padOffset& 'As Long
Dim arr1, arr2, v, v1, v2 'As Variant
Dim head, tmp, sortCols() 'As Variant
Dim re As Object, matches As Object
Dim s As String
If UBound(arr) - LBound(arr) = 0 Then
sortArray = arr
Exit Function
End If
If sortDirection <> 1 Then
sortDirection = -1
Set re = CreateObject("VBScript.RegExp")
padLen = 50: re.Global = True: re.MultiLine = True: re.IgnoreCase = True: re.Pattern = "[0-9]+"
On Error Resume Next
i = UBound(arr, 2)
If Err.Number <> 0 Then
sortMode = 1 '不是二维数组
If hasHeaders Then
ReDim tmp(LBound(arr) To UBound(arr) - 1)
ReDim head(1 To 1)
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then
If TypeOf arr(LBound(arr)) Is Object Then Set head(1) = arr(LBound(arr)) Else head(1) = arr(LBound(arr))
Else
If TypeOf arr(i) Is Object Then Set tmp(i - 1) = arr(i) Else tmp(i - 1) = arr(i)
End If
Next i
arr = tmp
Erase tmp
End If
Else
sortMode = 2
If hasHeaders Then
ReDim tmp(LBound(arr) To (UBound(arr) - 1), LBound(arr, 2) To UBound(arr, 2))
ReDim head(1 To 1, LBound(arr, 2) To UBound(arr, 2))
For i = LBound(arr) To UBound(arr)
For j = LBound(arr, 2) To UBound(arr, 2)
If i = LBound(arr) Then
If TypeOf arr(LBound(arr), j) Is Object Then Set head(1, j) = arr(LBound(arr), j) Else head(1, j) = arr(LBound(arr), j)
Else
If TypeOf arr(i, j) Is Object Then Set tmp(i - 1, j) = arr(i, j) Else tmp(i - 1, j) = arr(i, j)
End If
Next j
Next i
arr = tmp
Erase tmp
End If
End If
On Error GoTo 0
If sortMode = 1 Then
sortCols = Array(LBound(arr))
ElseIf IsNumeric(sortKeys) Then
tmp = Array(CLng(sortKeys))
ElseIf IsArray(sortKeys) Then
i = -1
On Error Resume Next
i = UBound(sortKeys, 2)
On Error GoTo 0
If i = -1 Then
tmp = sortKeys
Else
If IsNumeric(sortKeys(LBound(sortKeys), LBound(sortKeys, 2))) Then
tmp = Array(CLng(sortKeys(LBound(sortKeys), LBound(sortKeys, 2))))
Else
tmp = Array(LBound(arr, 2))
End If
End If
Else
tmp = Array(LBound(arr, 2))
End If
If sortMode = 2 Then
ReDim sortCols(LBound(tmp))
sortCols(LBound(tmp)) = LBound(arr, 2)
j = LBound(sortCols) - 1
For i = LBound(tmp) To UBound(tmp)
If IsNumeric(tmp(i)) Then
If CLng(tmp(i)) >= LBound(arr, 2) And CLng(tmp(i)) <= UBound(arr, 2) Then j = j + 1
If j > UBound(sortCols) Then
ReDim Preserve sortCols(LBound(sortCols) To j)
sortCols(j) = tmp(i)
End If
End If
Next i
Erase tmp
End If
y = LBound(sortCols)
mid = Int((UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) / 2)
If mid < LBound(arr) Then mid = LBound(arr)
If sortMode = 1 Then
ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0))
ReDim arr2(LBound(arr) To UBound(arr) - mid)
j = LBound(arr)
For i = LBound(arr1) To UBound(arr1)
If TypeOf arr(j) Is Object Then
Set arr1(i) = arr(j)
Else
arr1(i) = arr(j)
End If
j = j + 1
Next i
For i = LBound(arr2) To UBound(arr2)
If TypeOf arr(j) Is Object Then
Set arr2(i) = arr(j)
Else
arr2(i) = arr(j)
End If
j = j + 1
Next i
ElseIf sortMode = 2 Then
ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0), LBound(arr, 2) To UBound(arr, 2))
ReDim arr2(LBound(arr) To UBound(arr) - mid, LBound(arr, 2) To UBound(arr, 2))
j = LBound(arr)
For i = LBound(arr1) To UBound(arr1)
For k = LBound(arr1, 2) To UBound(arr1, 2)
If TypeOf arr(j, k) Is Object Then
Set arr1(i, k) = arr(j, k)
Else
arr1(i, k) = arr(j, k)
End If
Next k
j = j + 1
Next i
For i = LBound(arr2) To UBound(arr2)
For k = LBound(arr2, 2) To UBound(arr2, 2)
If TypeOf arr(j, k) Is Object Then
Set arr2(i, k) = arr(j, k)
Else
arr2(i, k) = arr(j, k)
End If
Next k
j = j + 1
Next i
End If
sortArray arr1, sortCols, , sortDirection '调用自身!!!
sortArray arr2, sortCols, , sortDirection '再次调用自身!!!
i = LBound(arr)
j = LBound(arr1)
k = LBound(arr2)
If sortMode = 1 Then
While j <= UBound(arr1) And k <= UBound(arr2)
If TypeOf arr1(j) Is Object Then v1 = ObjPtr(arr1(j)) Else v1 = arr1(j)
If TypeOf arr2(k) Is Object Then v2 = ObjPtr(arr2(k)) Else v2 = arr2(k)
If IsNumeric(v1) Then v1 = CDbl(v1)
If IsNumeric(v2) Then v2 = CDbl(v2)
If re.test(v1) And TypeName(v1) <> "Double" Then
Set matches = re.Execute(v1)
padOffset = 0
s = v1
For Each v In matches
s = Left(s, v.FirstIndex + padOffset) & Application.Rept("0", (padLen - Len(v))) & VBA.mid(s, v.FirstIndex + padOffset + 1)
padOffset = (padLen - Len(v))
Next v
v1 = s
s = vbNullString
End If
If re.test(v2) And TypeName(v2) <> "Double" Then
Set matches = re.Execute(v2)
padOffset = 0
s = v2
For Each v In matches
s = Left(s, v.FirstIndex + padOffset) & Application.Rept("0", (padLen - Len(v))) & VBA.mid(s, v.FirstIndex + padOffset + 1)
padOffset = (padLen - Len(v))
Next v
v2 = s
s = vbNullString
End If
If IsNumeric(v1) And IsNumeric(v2) Then
If (CDbl(v1) - CDbl(v2)) * sortDirection <= 0 Then
If TypeOf arr1(j) Is Object Then Set arr(i) = arr1(j) Else arr(i) = arr1(j)
j = j + 1
Else
If TypeOf arr2(k) Is Object Then Set arr(i) = arr2(k) Else arr(i) = arr2(k)
k = k + 1
End If
ElseIf StrComp(v1, v2, vbTextCompare) * sortDirection <= 0 Then
If TypeOf arr1(j) Is Object Then
Set arr(i) = arr1(j)
Else
arr(i) = arr1(j)
End If
j = j + 1
Else
If TypeOf arr2(k) Is Object Then
Set arr(i) = arr2(k)
Else
arr(i) = arr2(k)
End If
k = k + 1
End If
i = i + 1
Wend
While j <= UBound(arr1)
If TypeOf arr1(j) Is Object Then
Set arr(i) = arr1(j)
Else
arr(i) = arr1(j)
End If
j = j + 1
i = i + 1
Wend
While k <= UBound(arr2)
If TypeOf arr2(k) Is Object Then
Set arr(i) = arr2(k)
Else
arr(i) = arr2(k)
End If
k = k + 1
i = i + 1
Wend
ElseIf sortMode = 2 Then
While j <= UBound(arr1) And k <= UBound(arr2)
If TypeOf arr1(j, sortCols(y)) Is Object Then v1 = ObjPtr(arr1(j,sortCols(y))) Else v1 = arr1(j, sortCols(y))
If TypeOf arr2(k, sortCols(y)) Is Object Then v2 = ObjPtr(arr2(k,sortCols(y))) Else v2 = arr2(k, sortCols(y))
If IsNumeric(v1) Then v1 = CDbl(v1)
If IsNumeric(v2) Then v2 = CDbl(v2)
If re.test(v1) And TypeName(v1) <> "Double" Then
Set matches = re.Execute(v1)
padOffset = 0
s = v1
For Each v In matches
s = Left(s, v.FirstIndex + padOffset) & Application.Rept("0", (padLen - Len(v))) & VBA.mid(s, v.FirstIndex + padOffset + 1)
padOffset = (padLen - Len(v))
Next v
v1 = s
s = vbNullString
End If
If re.test(v2) And TypeName(v2) <> "Double" Then
Set matches = re.Execute(v2)
padOffset = 0
s = v2
For Each v In matches
s = Left(s, v.FirstIndex + padOffset) & Application.Rept("0", (padLen - Len(v))) & VBA.mid(s, v.FirstIndex + padOffset + 1)
padOffset = (padLen - Len(v))
Next v
v2 = s
s = vbNullString
End If
If IsNumeric(v1) And IsNumeric(v2) Then
If (CDbl(v1) - CDbl(v2)) * sortDirection < 0 Or (v1 = v2 And UBound(sortCols) = y) Then
For x = LBound(arr1, 2) To UBound(arr1, 2)
If TypeOf arr1(j, x) Is Object Then
Set arr(i, x) = arr1(j, x)
Else
arr(i, x) = arr1(j, x)
End If
Next x
j = j + 1
y = LBound(sortCols)
ElseIf (CDbl(v1) - CDbl(v2)) * sortDirection > 0 Then
For x = LBound(arr2, 2) To UBound(arr2, 2)
If TypeOf arr2(k, x) Is Object Then
Set arr(i, x) = arr2(k, x)
Else
arr(i, x) = arr2(k,x)
End If
Next x
k = k + 1
y = LBound(sortCols)
Else
i = i - 1
y = y + 1
End If
ElseIf StrComp(v1, v2, vbTextCompare) * sortDirection < 0 _
Or (StrComp(v1, v2, vbTextCompare) = 0 And UBound(sortCols) = y) Then
For x = LBound(arr1, 2) To UBound(arr1, 2)
If TypeOf arr1(j, x) Is Object Then
Set arr(i, x) = arr1(j, x)
Else
arr(i, x) = arr1(j, x)
End If
Next x
j = j + 1
y = LBound(sortCols)
ElseIf StrComp(v1, v2, vbTextCompare) * sortDirection > 0 Then
For x = LBound(arr2, 2) To UBound(arr2, 2)
If TypeOf arr2(k, x) Is Object Then
Set arr(i, x) = arr2(k, x)
Else
arr(i, x) = arr2(k, x)
End If
Next x
k = k + 1
y = LBound(sortCols)
Else
i = i - 1
y = y + 1
End If
i = i + 1
Wend
While j <= UBound(arr1)
For x = LBound(arr1, 2) To UBound(arr1, 2)
If TypeOf arr1(j, x) Is Object Then
Set arr(i, x) = arr1(j, x)
Else
arr(i, x) = arr1(j, x)
End If
Next x
j = j + 1
i = i + 1
Wend
While k <= UBound(arr2)
For x = LBound(arr2, 2) To UBound(arr2, 2)
If TypeOf arr2(k, x) Is Object Then
Set arr(i, x) = arr2(k, x)
Else
arr(i, x) = arr2(k, x)
End If
Next x
k = k + 1
i = i + 1
Wend
End If
If hasHeaders Then
If sortMode = 1 Then
'1d
ReDim tmp(LBound(arr) To UBound(arr) + 1)
If TypeOf head(1) Is Object Then Set tmp(LBound(tmp)) = head(1) Else tmp(LBound(tmp)) = head(1)
For i = LBound(arr) To UBound(arr)
If TypeOf arr(i) Is Object Then
Set tmp(i + 1) = arr(i)
Else
tmp(i + 1) = arr(i)
End If
Next i
Else
'2d
ReDim tmp(LBound(arr) To UBound(arr) + 1, LBound(arr, 2) To UBound(arr, 2))
For i = LBound(tmp) To UBound(tmp)
For j = LBound(tmp, 2) To UBound(tmp, 2)
If i = LBound(tmp) Then
If TypeOf head(1, j) Is Object Then Set tmp(i, j) = head(1, j) Else tmp(i, j) = head(1, j)
Else
If TypeOf arr(i - 1, j) Is Object Then
Set tmp(i, j) = arr(i - 1, j)
Else
tmp(i, j) = arr(i - 1, j)
End If
End If
Next
Next i
End If
arr = tmp
End If
Set re = Nothing
Set matches = Nothing
v1 = Empty
v2 = Empty
On Error Resume Next
Erase sortCols
Erase arr1
Erase arr2
Erase tmp
On Error GoTo 0
sortArray = arr
End Function下面是一个如何处理包含数字的字符串排序的小演示（可以使用自动筛选来查看默认排序与排序代码的结果对比）：
Sub smartNumberSort()
Dim a, i&
ReDim a(1 To 500)
a(1) = "Key"
For i = 2 To UBound(a)
a(i) = Chr(Int((25 * Rnd) + 65)) & " " & Int((100 * Rnd) + 1)
Next i
sortArray a, hasHeaders:=True ', sortDirection:=xlDescending '取消注释以查看反向排序
ActiveSheet.UsedRange.ClearContents
With Range("a1").Resize(UBound(a))
.Value = Application.Transpose(a)
.AutoFilter
End With
End Sub欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。
本文参与 腾讯云自媒体同步曝光计划，分享自微信公众号。
原始发表：2023-09-16 06:30，如有侵权请联系 cloudcommunity@tencent.com 删除
评论
登录后参与评论
暂无评论
推荐阅读
推荐阅读
相关推荐
ggplot2优雅绘制蛋白结构域与基因结构图
更多 >
腾讯云开发者
