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

相关推荐
QuantumStack28 分钟前
【C++ 真题】P1104 生日
开发语言·c++·算法
写个博客1 小时前
暑假算法日记第一天
算法
绿皮的猪猪侠1 小时前
算法笔记上机训练实战指南刷题
笔记·算法·pta·上机·浙大
hie988942 小时前
MATLAB锂离子电池伪二维(P2D)模型实现
人工智能·算法·matlab
杰克尼2 小时前
BM5 合并k个已排序的链表
数据结构·算法·链表
.30-06Springfield3 小时前
决策树(Decision tree)算法详解(ID3、C4.5、CART)
人工智能·python·算法·决策树·机器学习
我不是哆啦A梦3 小时前
破解风电运维“百模大战”困局,机械版ChatGPT诞生?
运维·人工智能·python·算法·chatgpt
xiaolang_8616_wjl3 小时前
c++文字游戏_闯关打怪
开发语言·数据结构·c++·算法·c++20
盛夏绽放3 小时前
Vue3 中 Excel 导出的性能优化与实战指南
vue.js·excel
small_wh1te_coder3 小时前
硬件嵌入式学习路线大总结(一):C语言与linux。内功心法——从入门到精通,彻底打通你的任督二脉!
linux·c语言·汇编·嵌入式硬件·算法·c