与之前写过的《Excel·VBA数组冒泡排序函数》不同,不是按照数值大小的升序/降序对数组进行排序,而是按照指定数组的顺序,对另一个数组进行排序
以下代码调用了《Excel·VBA数组冒泡排序函数》bubble_sort_arr
函数(如需使用代码需复制)
Function 按指定顺序排序(ByVal sorted, ByVal arr, Optional ByVal key_col& = 1, Optional start As Boolean = False)
'sorted已排序的数组,arr数组第key_col列将按sorted顺序排序,arr如果是一维数组则key_col无意义,key_col从1开始计数
'start参数为True时,arr数组第key_col列值的开头符合sorted中的值,也进行排序;否则排在最后(匹配模式)
'sorted数组可以是一维或二维,都会读取为字典(从上往下从左往右顺序);返回数组从1开始计数
Dim dict As Object, x&, a, c&, dc&, i&, j&, temp, result
Set dict = CreateObject("scripting.dictionary"): On Error Resume Next
For Each s In sorted 'sorted数组转换为字典,键为字符串,值为顺序号
If Not dict.Exists(s) Then x = x + 1: dict(s) = x
Next
x = 0: dc = dict.Count: a = TypeName(UBound(arr, 2)) '利用报错判断,获取数组维数
If a = "" Then 'arr为一维数组
c = UBound(arr) - LBound(arr) + 1: ReDim temp(1 To c, 1 To 2): ReDim result(1 To c)
For Each a In arr 'temp数组,第1列为对应arr的值,第2列为排序序号
x = x + 1: temp(x, 1) = a
For Each k In dict.keys
If a = k Then
temp(x, 2) = dict(k): Exit For '全部相同,使用排序序号
ElseIf start And a Like k & "*" Then '开头符合,使用排序序号+0.1
temp(x, 2) = dict(k) + 0.1: Exit For
End If
Next
If Len(temp(x, 2)) = 0 Then temp(x, 2) = dc + 1 '都不符合,排在最后
Next
temp = bubble_sort_arr(temp, 2) '调用函数排序
For x = 1 To c '排序结果写入result数组,并输出
result(x) = temp(x, 1)
Next
按指定顺序排序 = result
Else 'arr为二维数组
If LBound(arr) = 0 Or LBound(arr, 2) = 0 Then '转为从1开始计数
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
End If
c = UBound(arr): ReDim temp(1 To c, 1 To 2): ReDim result(1 To c, 1 To UBound(arr, 2))
For x = 1 To c 'temp数组,第1列为对应arr的序号,第2列为排序序号
temp(x, 1) = x: a = arr(x, key_col) 'key_col从1开始计数
For Each k In dict.keys
If a = k Then
temp(x, 2) = dict(k): Exit For '全部相同,使用排序序号
ElseIf start And a Like k & "*" Then '开头符合,使用排序序号+0.1
temp(x, 2) = dict(k) + 0.1: Exit For
End If
Next
If Len(temp(x, 2)) = 0 Then temp(x, 2) = dc + 1 '都不符合,排在最后
Next
temp = bubble_sort_arr(temp, 2) '调用函数排序
For i = 1 To c '排序结果写入result数组,并输出
x = temp(i, 1)
For j = 1 To UBound(arr, 2)
result(i, j) = arr(x, j)
Next
Next
按指定顺序排序 = result
End If
End Function
- 举例1
Sub 排序测试1()
Dim arr, brr, crr
'一维数组
arr = Array("A", "B", "C", "D", "E", "F")
brr = Array("AA", "C", "BB", "B", "CC", "A")
crr = 按指定顺序排序(arr, brr)
[e1].Resize(1, UBound(crr)) = crr '一维数组单行输出
'二维数组
arr = [a1].CurrentRegion: brr = [c1].CurrentRegion
crr = 按指定顺序排序(arr, brr)
[e1].Resize(UBound(crr), UBound(crr, 2)) = crr '二维数组单列输出
End Sub
start
参数为默认值False
,字符串完全相同时确定序号start
参数为True
,使用开头匹配模式,字符串完全相同或开头相同时确定序号,结果与上面不同
文章来源:https://www.toymoban.com/news/detail-824169.html
- 举例2
Sub 按指定顺序排序_测试()
Dim arr, brr, crr
arr = [a1].CurrentRegion: brr = [c1].CurrentRegion
crr = 按指定顺序排序(arr, brr, , True) '开头匹配模式
[f1].Resize(UBound(crr), UBound(crr, 2)) = crr
End Sub
start
参数为True
,使用开头匹配模式,字符串完全相同或开头相同时确定序号
文章来源地址https://www.toymoban.com/news/detail-824169.html
到了这里,关于Excel·VBA按指定顺序排序函数的文章就介绍完了。如果您还想了解更多内容,请在右上角搜索TOY模板网以前的文章或继续浏览下面的相关文章,希望大家以后多多支持TOY模板网!