vba二维数组多key稳定排序

作者:仇朝权 时间:24-06-10 阅读数:1037人阅读

此代码为Excel Home论坛的香川裙子所做,经测试,效果不错。szpx函数返回的是一个一维数组,下标从1开始,里面记录的是原数组的行,直接调用即可。

比如:如数据arr是100行,7列的数组,排序给brr=szpx(arr,0,1,2),数组brr是brr(1)~brr(100),里面记录的是排序后原来数组的序号。(有点绕,好好理解下)

如果无法理解上面的话,用szbr输出排序后的数组即可。因为大多数时候没有必要输出数组,直接根据szpx后的结果在arr中取该值即可。

下面是改排序在mqcal工程算量中辅助输入的应用:(查找数据后排序)

排序在mqcal辅助输入中的应用

Sub test1px() '【二维数组多key稳定排序】的应用示例
    Dim ar, br, nr, sr, h&, i&, j&, m&, n&, r&, tms#
    m = 20000: n = 7
    ReDim a(1 To m, 1 To n)
    For i = 1 To m
        a(i, 1) = i
        For j = 2 To n
            r = Int(Rnd * 10): If r Then a(i, j) = r
        Next
    Next
    ar = a '以上生成m行n列的VBA内存二维数组
'    ar = [k1].CurrentRegion.Value '也可直接读取工作表区域得到二维数组
    sr = Array(3, 1, 5, 2, 7, 1) '按权重优先顺序key、Sort值交替排列的一维数组。key为列序号、Sort值:1升序、2降序
'    sr = Array(3, -1, 5, 2, 7, -1)'Sort值=-1时,升序并且空值会在最前面。(Sort=1时按工作表排序方法空值排在最后)
                                   'Sort值=2时、降序而空值自然会在最后。
    tms = Timer
    nr = szpx(ar, 0, sr) '第1参数为待排序二维数组、第2参数为不参与排序的标题行的行数
                         '第3参数为按权重优先顺序key、Sort值交替排列的一维数组。
    Debug.Print "Sort1: " & Format(Timer - tms, "0.00s ") & "Sort"
'    nr = szpx(ar, 0, 3, 1, 5, 2, 7, 1) '也可这样写入参数。从第3个参数开始交替写入key、Sort值。推荐第1种写法。
'    Exit Sub
'    下面是返回排序后数组结果?并输出到工作表的代码
    br = szbr(ar, nr, 0): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
End Sub
Function szpx(ar, h&, ParamArray sr()) 'by kagawa 2015/12/4-12/7 主要参考借鉴了Zamyi大侠的二维数组多key排序算法
    '第1参数ar:为待排序二维数组、第2参数h:为不参与排序的标题行的行数
    '第3参数sr:为按权重优先顺序key、Sort值交替排列的一维数组、或以逗号分隔直接写入Key、Sort值。
    Dim br, y, sr2, i&, i2&, i3&, i4&, j&, j2&, k&, l&, u&, s&, t
    l = LBound(ar) + h: u = UBound(ar) '获取数组起始、结束位置
    ReDim x&(l To u), z(l To u + 1) As Boolean '定义存放Index序号的数组x、标记段落结束位置的数组z
    For i = l To u
        x(i) = i 'Index赋值为数组行序号、这以后排序就只需改变这个Index位置、原始数组无需改变
    Next
    z(u + 1) = True '标记最后结束位置
    If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr '判断第3参数是数组、还是多Key、Sort值序列
    j = sr2(0): If sr2(1) Mod 2 Then Call QuickSort1(ar, x, j, l, u) Else Call QuickSort2(ar, x, j, l, u)
    '按key1先进行QuickSort排序
    If sr2(1) = 1 Then Call AZE(ar, x, j, l, u) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
    For k = 2 To UBound(sr2) Step 2 '接着循环继续key2以后的排序
'        br = szbr(ar, x, h): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
        j2 = sr2(k): s = sr2(k + 1) '读取排序key的列序号j2 和Sort值s
        i = l: t = ar(x(i), j): i2 = i 'Do循环检查是否前key相同【注意,仅仅前key相同部分需要继续排序】
        Do
            Do
                i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then z(i2) = True: Exit Do
                '递增检查如果到了前前key的结束位置、或前key不同则停止退出Do循环
            Loop
            If i2 - i > 1 Then '如果间隔>1 则本key需要排序处理【注意排序区间是小范围i,i2-1】
                If s Mod 2 Then Call QuickSort1(ar, x, j2, i, i2 - 1) Else Call QuickSort2(ar, x, j2, i, i2 - 1)
                If s = 1 Then Call AZE(ar, x, j2, i, i2 - 1) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
            End If
            If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续从i2重新开始Do循环
        Loop
        j = j2 '更新前key列位置j
    Next
    '全部排序循环结束后、为保证最后的排序稳定性、检查最后的key值相同时必须按Index值排序。
    i = l: t = ar(x(i), j): i2 = i
    Do
        Do
            i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then Exit Do '检查方法相同
        Loop
        If i2 - i > 1 Then Call QuickSort(x, i, i2 - 1) '如果间隔>1 则Index值需要排序处理
        If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续
    Loop
    szpx = x '多key稳定排序处理结束、返回排序结果的Index数组x
'    szpx = szbr(ar, x, h) '或返回按排序后Index顺序引用返回的排序结果数组br
End Function
Function QuickSort(x, l&, u&) 'A-Z QuickSort '最后稳定排序时对相同key的Index值升序排序
    Dim i&, j&, n&, r&
    i = l: j = u: r = x((l + u) \ 2)
    While i < j
        While x(i) < r: i = i + 1: Wend 'A-Z
        While x(j) > r: j = j - 1: Wend 'A-Z
        If i <= j Then: n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort(x, l, j)
    If i < u Then Call QuickSort(x, i, u)
End Function
Function QuickSort1(ar, x, j2&, l&, u&) 'A-Z QuickSort 按原数组j2列对应内容进行升序排序
    Dim i&, j&, n&, r
    i = l: j = u: r = ar(x((l + u) \ 2), j2)
    While i < j
        While ar(x(i), j2) < r And i < u: i = i + 1: Wend   'A-Z
        While ar(x(j), j2) > r And j > l: j = j - 1: Wend   'A-Z
        If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort1(ar, x, j2, l, j)
    If i < u Then Call QuickSort1(ar, x, j2, i, u)
End Function
Function QuickSort2(ar, x, j2&, l&, u&) 'Z-A QuickSort 按原数组j2列对应内容进行降序排序
    Dim i&, j&, n&, r
    i = l: j = u: r = ar(x((l + u) \ 2), j2)
    While i < j
        While ar(x(i), j2) > r And i < u: i = i + 1: Wend 'Z-A
        While ar(x(j), j2) < r And j > l: j = j - 1: Wend 'Z-A
        If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
    Wend
    If l < j Then Call QuickSort2(ar, x, j2, l, j)
    If i < u Then Call QuickSort2(ar, x, j2, i, u)
End Function
Function AZE(ar, x, j, l&, u&) 'Sort值=1时、把排序完成后的空值移动到最后
    Dim i&, i2&, y
    For i = l To u
        If ar(x(i), j) <> "" Then '检查直到非空位置时停止
            y = x '复制Index数组x到y
            For i2 = l To i - 1
                x(u - i + i2 + 1) = y(i2) '前面的空值对应Index值移动到最后
            Next
            For i2 = i To u
                x(i2 - i + l) = y(i2) '后面的非空值对应Index值移动到前面
            Next
            Exit For
        End If
    Next
End Function
Function szbr(ar, nr, h&) 'Output Result Array 按排序后nr数组顺序、引用原数组对应Index值各列返回数组排序结果
    Dim br, i&, i2&, j2&, l&, l2&, u&, u2&
    l = LBound(ar) + h: u = UBound(ar)
    l2 = LBound(ar, 2): u2 = UBound(ar, 2)
    br = ar
    For i = l To u
        i2 = nr(i) '引用原数组对应Index值
        For j2 = l2 To u2
            br(i, j2) = ar(i2, j2) '按排序结果引用原数组对应值返回
        Next
    Next
    szbr = br
End Function


[本文转自仇朝权随笔_vba二维数组多key稳定排序](http://zawen.net/post/85.html)

分享到:

♡♡♡转载请保留上面信息♡♡♡

发表评论