Excel·VBA按指定顺序排序函数

与之前写过的《Excel·VBA数组冒泡排序函数》不同，不是按照数值大小的升序/降序对数组进行排序，而是按照指定数组的顺序，对另一个数组进行排序

以下代码调用了《Excel·VBA数组冒泡排序函数》bubble_sort_arr函数（如需使用代码需复制）

vbnet 复制代码

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

vbnet 复制代码

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，使用开头匹配模式，字符串完全相同或开头相同时确定序号，结果与上面不同

举例2

vbnet 复制代码

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，使用开头匹配模式，字符串完全相同或开头相同时确定序号