印刷下单网站开发网站自动收录

与之前写过的《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, resultSet dict = CreateObject("scripting.dictionary"): On Error Resume NextFor Each s In sorted  'sorted数组转换为字典，键为字符串，值为顺序号If Not dict.Exists(s) Then x = x + 1: dict(s) = xNextx = 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) = aFor Each k In dict.keysIf a = k Thentemp(x, 2) = dict(k): Exit For    '全部相同，使用排序序号ElseIf start And a Like k & "*" Then  '开头符合，使用排序序号+0.1temp(x, 2) = dict(k) + 0.1: Exit ForEnd IfNextIf Len(temp(x, 2)) = 0 Then temp(x, 2) = dc + 1  '都不符合，排在最后Nexttemp = bubble_sort_arr(temp, 2)  '调用函数排序For x = 1 To c  '排序结果写入result数组，并输出result(x) = temp(x, 1)Next按指定顺序排序 = resultElse  'arr为二维数组If LBound(arr) = 0 Or LBound(arr, 2) = 0 Then  '转为从1开始计数arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))End Ifc = 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.keysIf a = k Thentemp(x, 2) = dict(k): Exit For    '全部相同，使用排序序号ElseIf start And a Like k & "*" Then  '开头符合，使用排序序号+0.1temp(x, 2) = dict(k) + 0.1: Exit ForEnd IfNextIf Len(temp(x, 2)) = 0 Then temp(x, 2) = dc + 1  '都不符合，排在最后Nexttemp = 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)NextNext按指定顺序排序 = resultEnd 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].CurrentRegioncrr = 按指定顺序排序(arr, brr)[e1].Resize(UBound(crr), UBound(crr, 2)) = crr  '二维数组单列输出
End Sub

start参数为默认值False，字符串完全相同时确定序号

start参数为True，使用开头匹配模式，字符串完全相同或开头相同时确定序号，结果与上面不同

• 举例2

Sub 按指定顺序排序_测试()Dim arr, brr, crrarr = [a1].CurrentRegion: brr = [c1].CurrentRegioncrr = 按指定顺序排序(arr, brr, , True)  '开头匹配模式[f1].Resize(UBound(crr), UBound(crr, 2)) = crr
End Sub

start参数为True，使用开头匹配模式，字符串完全相同或开头相同时确定序号