| Excel·VBA按指定顺序排序函数 | 您所在的位置：网站首页 › excel按顺序排列内容 › Excel·VBA按指定顺序排序函数 |
Excel·VBA按指定顺序排序函数
|
与之前写过的《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 Substart参数为默认值False，字符串完全相同时确定序号 start参数为True，使用开头匹配模式，字符串完全相同或开头相同时确定序号 |
start参数为True，使用开头匹配模式，字符串完全相同或开头相同时确定序号，结果与上面不同 
【本文地址】
公司简介
联系我们