VBA内存二维数组对象的多key稳定排序算法

ivccav

但是，如果是VBA过程中生成的VBA内存二维数组需要排序，那么用工作表排序方法就比较麻烦，需要先把二维数组写入工作表，然后排序，然后再读入VBA……

————居然中枪了！呵呵。我一直都是这么干的。

ivccav

感谢香老师的普及帖！对于我们这些不吃编程这碗饭的童鞋来说，非常实用。总不能为了了解一个算法，去啃TAOCP吧？看不看得懂另说，花的时间也是极大的。

五指山888

好贴，收藏了，好好学习

jiaoguoguo

刚刚了解了点字典和数组循环的配套使用，速度上提升明显，如果能在数组中像表格一样高级排序就更好了！

乐乐2006201505

香川群子 发表于 2015-12-8 16:02
按你附件的要求，用我的二维数组多key排序写了2个代码，比工作表排序大约快3倍。

方法-1、把cx列也列 ...

香川群子大师，敬请您指点一下。非常感谢！
附件暂时无法上传，等可以上传后马上上传。主要是标题行问题，默认为0，第一段代码中修改后，后边自定义函数中不会随着变动。
Option Explicit
Sub test2() '【二维数组多key稳定排序】算法2 的应用示例
    Dim ar, br, nr, sr, h&, i&, tms#
    tms = Timer
    h = 0 '标题行行数
    ar = [a1].CurrentRegion.Value
    Debug.Print "Sort2: " & Format(Timer - tms, "0.00s ") & "Input"

    sr = Array(4, 1, 1, 1, 3, 1)
'    sr = Array(1, 1, 3, 1, 5, 1, 7, 2)
'    sr = Array(1, 1, 3, -1, 5, -1, 7, -1)

    tms = Timer
    For i = 1 To 1 * 10 ^ 0
        nr = szpx2(ar, h, sr)
    Next
    Debug.Print "Sort2: " & Format(Timer - tms, "0.00s ") & "Sort"

    br = szbr(ar, nr, 0): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
    Debug.Print "Sort2: " & Format(Timer - tms, "0.00s ") & "Output"
End Sub

Function szpx2(ar, h&, ParamArray sr()) 'by kagawa 2015/12/4-12/7 本算法是kagawa原创、但效率很低不实用。
    Dim br, kr, nr, sr2, i&, j&, l&, u&
'    h = 2
    l = LBound(ar) + h: u = UBound(ar)
    ReDim x&(l To u)
    For i = l To u
        x(i) = i
    Next

    If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr
    nr = x
    For j = UBound(sr2) To 1 Step -2 '模仿工作表排序方法、倒序处理各个key【这也是算法失败的原因】
        kr = x: Call px2(ar, kr, nr, CLng(sr2(j - 1)), l, u, CLng(sr2(j)))
'        br = szbr(ar, nr, h): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
    Next
    szpx2 = nr
'    szpx2 = szbr(ar, nr, h)
End Function
Function px2(ar, kr, nr, j&, l&, u&, s&) 'by kagawa 2015/12/4
    Dim i&, i2&, k&, k2&, t
    k = u: ReDim tr(l To u + 1)
    If s = -1 Then 's=-1(Empty-A-Z)(空白在最前面的升序排序【会和工作表排序结果不同】)
        For i = l To u
            tr(i) = ar(nr(i), j)
        Next
    Else 's=1(A-Z-Empty) or s=2(Z-A-Empty) 空白始终在最后的升/降序排序【和工作表排序结果同】
        For i = l To u
            t = ar(nr(i), j): If Len(t) Then tr(i) = t Else k = i - 1: k2 = 0: Exit For
        Next
        If i < u Then 'i=u
            ReDim y&(u - l)
            For i = i To u '检查并把空白内容对应Index值记录到临时数组y
                t = ar(nr(i), j): If Len(t) Then k = k + 1: nr(k) = nr(i): tr(k) = t Else k2 = k2 + 1: y(k2) = nr(i)
            Next
            For i = 1 To k2
                nr(k + i) = y(i) '把临时数组y中的空白内容对应Index值搬移到最后
            Next
            Call Sort20(nr, kr, k + 1, u) 'Quick Sort 搬移后需要升序排序
        End If
    End If

    If s Mod 2 Then Call Sort21(kr, nr, tr, l, k) Else Call Sort22(kr, nr, tr, l, k)
    '本列按Sort值进行升序或降序排序

    '检查内容相同时、Index值按本次初始kr顺序排序、恢复稳定性【是保证稳定性的关键】
    '【但由于本算法每次都需从头到尾排序、然后恢复稳定性处理 所以效率很低、失败了】
    For i = l To k - 1
        If tr(i + 1) = tr(i) Then
            For i2 = i + 1 To k
                If tr(i2 + 1) <> tr(i) Then
                    If tr(i) = "" Then Call Sort20(nr, kr, i, i2) Else Call Sort20(kr, nr, i, i2)                     'Quick Sort
                    i = i2: Exit For
                End If
            Next
        End If
    Next
End Function
Function Sort20(kr, nr, l&, u&) 'QuickSort
    Dim i&, j&, k&, n&, r&
    i = l: j = u: r = kr((l + u) \ 2)
    While i < j
        While kr(i) < r: i = i + 1: Wend
        While kr(j) > r: j = j - 1: Wend
        If i <= j Then
            k = kr(i): kr(i) = kr(j): kr(j) = k '恢复稳定性根据的本次排序前顺序
            n = nr(i): nr(i) = nr(j): nr(j) = n '记录排序结果的Index值
            i = i + 1: j = j - 1
        End If
    Wend
    If l < j Then Call Sort20(kr, nr, l, j)
    If i < u Then Call Sort20(kr, nr, i, u)
End Function
Function Sort21(kr, nr, tr, l&, u&) 'A-Z QuickSort
    Dim i&, j&, k&, n&, r, t
    i = l: j = u: r = tr((l + u) \ 2)
    While i < j
        While tr(i) < r: i = i + 1: Wend 'A-Z
        While tr(j) > r: j = j - 1: Wend 'A-Z
        If i <= j Then
            k = kr(i): kr(i) = kr(j): kr(j) = k '恢复稳定性需要的本次排序前顺序
            n = nr(i): nr(i) = nr(j): nr(j) = n '记录排序结果的Index值
            t = tr(i): tr(i) = tr(j): tr(j) = t '本次排序对象
            i = i + 1: j = j - 1
        End If
    Wend
    If l < j Then Call Sort21(kr, nr, tr, l, j)
    If i < u Then Call Sort21(kr, nr, tr, i, u)
End Function
Function Sort22(kr, nr, tr, l&, u&) 'Z-A QuickSort
    Dim i&, j&, k&, n&, r, t
    i = l: j = u: r = tr((l + u) \ 2)
    While i < j
        While tr(i) > r: i = i + 1: Wend 'Z-A
        While tr(j) < r: j = j - 1: Wend 'Z-A
        If i <= j Then
            k = kr(i): kr(i) = kr(j): kr(j) = k '恢复稳定性需要的本次排序前顺序
            n = nr(i): nr(i) = nr(j): nr(j) = n '记录排序结果的Index值
            t = tr(i): tr(i) = tr(j): tr(j) = t '本次排序对象
            i = i + 1: j = j - 1
        End If
    Wend
    If l < j Then Call Sort22(kr, nr, tr, l, j)
    If i < u Then Call Sort22(kr, nr, tr, i, u)
End Function

Function szbr(ar, nr, h&) 'Output Result Array 按排序后nr数组顺序、引用原数组对应Index值各列返回数组排序结果
    Dim br, i&, i2&, j2&, l&, l2&, u&, u2&
'    h = 2
    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

weisilisid

好帖，收藏‘’好好学习

txh0011

做了标记，深深觉得需要好好学习。

peter-chen

好贴，收藏了，好好学习

holyabc

最近想在word里对表进行竖排，横排切换，正好能用到这些，十分感谢
表                       
1                5       
2                6       
3                7       
4                8       
表2                       
1                2       
3                4       
5                6       
7                8       

ychj526926

香川群子 发表于 2015-12-4 15:10
该排序方法写成了Function形式，可以一句代码引用：

nr = szpx(ar, 0, 3, 1, 5, 2, 7, 1)

大神你好，我用你写的这个VBA，使用是当数据量大时会提示错误28，内存栈溢出