ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2606|回复: 10

[原创] 二維陣列快速插入穩定遞增排序

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-2-17 00:59 | 显示全部楼层 |阅读模式
Option Explicit
Option Base 1
Option Compare Text

Public Sub S_二維陣列快速插入穩定遞增排序_01(ByRef 原始二維陣列 As Variant, ByVal 排序維度 As Long, ByVal 排序鍵值 As Long, ByVal 起限 As Long, ByVal 迄限 As Long)

    On Error Resume Next

    If 起限 >= 迄限 Then
        Exit Sub
    End If

    '------------------------------------------------------

    Dim X As Long
    Dim Y As Long

    Dim 擷取成一維陣列 As Variant
    Dim 索引陣列() As Long

    '------------------------------------------------------

    ReDim 擷取成一維陣列(起限 To 迄限) As Variant
    ReDim 索引陣列(起限 To 迄限) As Long

    If 排序維度 = 1 Then
        For X = 起限 To 迄限
            擷取成一維陣列(X) = 原始二維陣列(X, 排序鍵值)
            索引陣列(X) = X
        Next X
    Else
        For Y = 起限 To 迄限
            擷取成一維陣列(Y) = 原始二維陣列(排序鍵值, Y)
            索引陣列(Y) = Y
        Next Y
    End If

    '------------------------------------------------------

    二維陣列快速插入穩定遞增排序 擷取成一維陣列, 索引陣列, 起限, 迄限

    '------------------------------------------------------

    Dim 複製原始二維陣列 As Variant

    複製原始二維陣列 = 原始二維陣列

    If 排序維度 = 1 Then
        For X = 起限 To 迄限
            For Y = LBound(原始二維陣列, 2) To UBound(原始二維陣列, 2)
                原始二維陣列(X, Y) = 複製原始二維陣列(索引陣列(X), Y)
            Next Y
        Next X
    Else
        For Y = 起限 To 迄限
            For X = LBound(原始二維陣列, 1) To UBound(原始二維陣列, 1)
                原始二維陣列(X, Y) = 複製原始二維陣列(X, 索引陣列(Y))
            Next X
        Next Y
    End If

End Sub

Public Sub 二維陣列快速插入穩定遞增排序(ByRef 原始一維陣列 As Variant, ByRef 索引陣列() As Long, ByVal 起限 As Long, ByVal 迄限 As Long)

    On Error Resume Next

    If 起限 >= 迄限 Then
        Exit Sub
    End If

    '------------------------------------------------------

    Dim X As Long
    Dim Y As Long
    Dim S As Long
    Dim M As Long
    Dim E As Long
    Dim N As Long

    Dim 暫存 As Variant
    Dim 索引暫存 As Long
    Dim 基準 As Variant

    '------------------------------------------------------

    If 迄限 - 起限 < 16 Then
        For X = 起限 + 1 To 迄限
            暫存 = 原始一維陣列(X)
            索引暫存 = 索引陣列(X)

            For Y = X - 1 To 起限 Step -1
                If 暫存 >= 原始一維陣列(Y) Then
                    Exit For
                End If

                原始一維陣列(Y + 1) = 原始一維陣列(Y)
                索引陣列(Y + 1) = 索引陣列(Y)
            Next Y

            原始一維陣列(Y + 1) = 暫存
            索引陣列(Y + 1) = 索引暫存
        Next X
    Else
        Dim 基準陣列(3) As Variant

        基準陣列(1) = 原始一維陣列(起限)
        基準陣列(2) = 原始一維陣列((起限 + 迄限) \ 2)
        基準陣列(3) = 原始一維陣列(迄限)

        For X = 2 To 3
            暫存 = 基準陣列(X)

            For Y = X - 1 To 1 Step -1
                If 暫存 >= 基準陣列(Y) Then
                    Exit For
                End If

                基準陣列(Y + 1) = 基準陣列(Y)
            Next Y

            基準陣列(Y + 1) = 暫存
        Next X

        基準 = 基準陣列(2)

        '------------------------------------------------------

        Dim 起陣列 As Variant
        Dim 基陣列 As Variant
        Dim 迄陣列 As Variant
        Dim 索引起陣列() As Long
        Dim 索引基陣列() As Long
        Dim 索引迄陣列() As Long

        ReDim 起陣列(迄限 - 起限) As Variant
        ReDim 基陣列(迄限 - 起限 + 1) As Variant
        ReDim 迄陣列(迄限 - 起限) As Variant
        ReDim 索引起陣列(迄限 - 起限) As Long
        ReDim 索引基陣列(迄限 - 起限 + 1) As Long
        ReDim 索引迄陣列(迄限 - 起限) As Long

        S = 0
        M = 0
        E = 0
        For X = 起限 To 迄限
            暫存 = 原始一維陣列(X)
            索引暫存 = 索引陣列(X)

            If 暫存 < 基準 Then
                S = S + 1
                起陣列(S) = 暫存
                索引起陣列(S) = 索引暫存
            ElseIf 暫存 = 基準 Then
                M = M + 1
                基陣列(M) = 暫存
                索引基陣列(M) = 索引暫存
            Else
                E = E + 1
                迄陣列(E) = 暫存
                索引迄陣列(E) = 索引暫存
            End If
        Next X

        '------------------------------------------------------

        If S > 1 Then
            二維陣列快速插入穩定遞增排序 起陣列, 索引起陣列, 1, S
        End If

        If E > 1 Then
            二維陣列快速插入穩定遞增排序 迄陣列, 索引迄陣列, 1, E
        End If

        '------------------------------------------------------

        N = 起限 - 1
        For X = 1 To S
            N = N + 1
            原始一維陣列(N) = 起陣列(X)
            索引陣列(N) = 索引起陣列(X)
        Next X

        For X = 1 To M
            N = N + 1
            原始一維陣列(N) = 基陣列(X)
            索引陣列(N) = 索引基陣列(X)
        Next X

        For X = 1 To E
            N = N + 1
            原始一維陣列(N) = 迄陣列(X)
            索引陣列(N) = 索引迄陣列(X)
        Next X
    End If

End Sub

TA的精华主题

TA的得分主题

发表于 2017-2-17 10:18 | 显示全部楼层
本帖最后由 香川群子 于 2017-2-17 10:32 编辑

读了代码。

功能:对一个二维数组,可按指定行或指定列进行全数组排序。
并保证排序结果是稳定的。(相同值按原始顺序排列)

过程:
Step-1: 读取指定行或列的数据到一维数组,并生成自然序列索引数组。
Step-2: 调用排序过程,对区间内一维数组的数据进行排序,得到排序后的新的索引序列。
   排序过程:
        如果区间<16则按插入排序操作。
        否则按快速排序:
           1. 取首、尾、中间3个值排序、得到排序比较基准值
           2. 遍历排序区间、按数据比较结果分别存入 小、中(相等)、大 三个数组
           3. 依次对小、大数组进一步递归排序
           4. 排序结果合并为一个数组
      直至完成所有区间的排序
Step-3:根据最后得到的排序后索引序列,对原始数组进行位置交换,完成二维数组的排序。

……
为了保证稳定排序吧,你这个快速排序的过程较通常的快速排序要复杂一些。

呵呵。有点意思。






TA的精华主题

TA的得分主题

发表于 2017-2-17 10:37 | 显示全部楼层
问题点:
1. 只能进行升序排序,不能降序排序
2. 只能对1行或1列进行排序,不能同时进行多行、多列的多key排序

所以完整的二维数组多key稳定排序解决方法在这里:
VBA内存二维数组对象的多key稳定排序算法 [url]http://club.excelhome.net/thread-1245495-1-1.html (出处: ExcelHome技术论坛)[/url]

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-2-17 10:39 | 显示全部楼层
您真是好熱心啊!
幫忙解釋這個代碼。

確實是想要保證排序穩定,不曉得還有沒有更好的方法?

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-2-17 10:43 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 linyancheng 于 2017-2-17 10:50 编辑
香川群子 发表于 2017-2-17 10:37
问题点:
1. 只能进行升序排序,不能降序排序
2. 只能对1行或1列进行排序,不能同时进行多行、多列的多ke ...

對,我只先寫遞增,搞定以後,在第一個Sub再加入遞減,然後把遞減寫在另一個副Sub, 這樣比較不會影響速度,對吧?
您的多key排序我有看過,不過有點難度,我是先用這個逆向一個一個排序。
不曉得您的代碼(我沒看出)是穩定的排法嗎?

TA的精华主题

TA的得分主题

发表于 2017-2-17 10:49 | 显示全部楼层
linyancheng 发表于 2017-2-17 10:39
您真是好熱心啊!
幫忙解釋這個代碼。

我的代码算法是借鉴Zamyi大侠的。

原理如下:
1. 建立自然序号索引数组
2. 按照key1排序、同时改变索引顺序
3. 检查key1【相同时】则按key2排序、同时改变索引顺序
    继续直至多key全部排序完成
4. 检查最后key【相同】的部分,按索引数值大小排序……这样就保证最后排序结果是稳定的。
5. 按照最后的索引排序结果,交换原始数组位置完成排序。

…………
最大的优点是:多key排序中第2key以后,循环检查仅对前key相同的部分进行快速排序。
因此排序效率是很高的。


另外,我的代码中还兼容了空白内容排序位置到最后的工作表排序方式。
这是一般自定义排序中没有考虑的。

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-2-17 10:58 | 显示全部楼层
本帖最后由 linyancheng 于 2017-2-17 10:59 编辑
香川群子 发表于 2017-2-17 10:49
我的代码算法是借鉴Zamyi大侠的。

原理如下:

請問一下,3.4.兩步驟是否是交互進行?
這方法我也想過,不知道會不會比較快,
可否請您幫忙測試一下,一個Key時,兩者的速度差多少?

TA的精华主题

TA的得分主题

发表于 2017-2-17 12:49 | 显示全部楼层
你的算法呢,速度效率和数据结构大有关联。

排序对象列中相同值较多、且自然符合排序部分越多,你的方法较快。
即,如果是 1,2,2,3,3,4,5,5,5……类似这样的,你的速度飞快。
但是,如果是 9,8,7,6,5,4,3,2,1……类似这样完全逆序且没有重复的,你的速度就会一下子慢下来。

总体来说,数据量1万行以内差别不大。

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-2-17 13:28 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 linyancheng 于 2017-2-17 14:06 编辑
香川群子 发表于 2017-2-17 12:49
你的算法呢,速度效率和数据结构大有关联。

排序对象列中相同值较多、且自然符合排序部分越多,你的方法 ...

抱歉,您的代碼我還不太會用,我測試我自己的。

排序陣列:10000 x 2 的整數(但我的引數代碼是Variant)

1.不重複數字:順序→執行100次總合→12.525秒
       逆序→執行100次總合→14.420秒
       亂序→執行100次總合→14.602秒
2.重複數字:順序→執行100次總合→8.897秒
      逆序→執行100次總合→9.236秒
      亂序→執行100次總合→9.146秒
(重複數字大概在5~20個之間)
估計重複不重複影響快排較大,順序較快,可能是插排的影響,我的快排應該比較不受順序影響(一般的快排順序會比較快)
逆序及亂序相差不大。
如果是用您維持穩定的方法,重複愈多是否會愈慢?

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-2-17 18:42 | 显示全部楼层
理論上時間:
插入排序:順序<亂序<逆序,重複<不重複
您的穩定快速排序:順序<亂序≒逆序,重複>不重複
我的穩定快速插入排序:順序<逆序≒亂序,重複<不重複
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-11 17:24 , Processed in 0.051036 second(s), 8 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表