设为首页收藏本站
简字体切换切换到宽版

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

搜索
ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › VBA内存二维数组对象的多key稳定排序算法
EH技术汇-专业的职场技能充电站 妙哉！函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
1234567下一页
返回列表 发新帖
楼主: 香川群子

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

  [复制链接]
香川群子

TA的精华主题

TA的得分主题
 楼主| 发表于 2015-12-8 16:07 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
本帖已被收录到知识树中，索引项：排序
似乎无法上传附件……

那就先贴出代码：
  1. Sub szpx_2()
  2.     Dim arr, ar, br, nr, sr, h&, i&, i2&, j&, j2&, k&, l&, l2&, m&, u&, u2&, tm#, tms#
  3.     tms = Timer
  4.     Debug.Print vbCr; "szpx_2"
  5.    
  6.     tm = Timer
  7.     Sheet1.Activate
  8.     m = [a3].End(4).Row
  9.     arr = [a1].Resize(m, 103)
  10.     h = 2
  11.     ReDim ar(m, 3)
  12.     For i = h + 1 To m
  13.         If arr(i, 102) Then ar(k, 0) = i: ar(k, 1) = arr(i, 103): ar(k, 2) = Val(arr(i, 1)): ar(k, 3) = arr(i, 2): k = k + 1
  14.     Next
  15.     Debug.Print Format(Timer - tm, "0.00s ") & "Get ar"
  16.    
  17.     tm = Timer
  18.     sr = Array(1, 2, 2, 2, 3, 1)
  19.     nr = szpx2(ar, 0, k - 1, sr)
  20.     Debug.Print Format(Timer - tm, "0.00s ") & "Sort"
  21.    
  22.     tm = Timer
  23.     l = LBound(nr): u = UBound(nr)
  24.     l2 = LBound(arr, 2): u2 = UBound(arr, 2)
  25.     ReDim br(l - h To u, l2 To u2)
  26.     For i = 1 To h
  27.         For j2 = l2 To u2
  28.             br(l - h + i - 1, j2) = arr(LBound(arr) + i - 1, j2)
  29.         Next
  30.     Next
  31.     For i = l To u
  32.         i2 = ar(nr(i), 0)
  33.         For j2 = l2 To u2
  34.             br(i, j2) = arr(i2, j2)
  35.         Next
  36.     Next
  37.     Debug.Print Format(Timer - tm, "0.00s ") & "Output"
  38.    
  39.     tm = Timer
  40.     Sheet2.Activate
  41.     [a1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
  42.     Debug.Print Format(Timer - tm, "0.00s ") & "Output"
  43.    
  44.     Debug.Print Format(Timer - tms, "0.00s ") & "Total"
  45.     MsgBox Format(Timer - tms, "0.00s ") & u - l + 1
  46. End Sub
  47. Function szpx2(ar, l&, u&, ParamArray sr()) 'by kagawa 2015/12/4-12/7
  48.     Dim br, y, sr2, i&, i2&, i3&, i4&, j&, j2&, k&, s&, t
  49.    
  50.     ReDim x&(l To u), z(l To u + 1) As Boolean
  51.     For i = l To u
  52.         x(i) = i
  53.     Next
  54.     z(u + 1) = True
  55.    
  56.     If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr
  57.     j = sr2(0): If sr2(1) Mod 2 Then Call QSort1(ar, x, j, l, u) Else Call QSort2(ar, x, j, l, u)
  58. '    If sr2(1) = 1 Then Call AZE(ar, x, j, l, u)
  59.     For k = 2 To UBound(sr2) Step 2
  60.         j2 = sr2(k): s = sr2(k + 1)
  61.         i = l: t = ar(x(i), j): i2 = i
  62.         Do
  63.             Do
  64.                 i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then z(i2) = True: Exit Do
  65.             Loop
  66.             If i2 - 1 > i Then
  67.                 If s Mod 2 Then Call QSort1(ar, x, j2, i, i2 - 1) Else Call QSort2(ar, x, j2, i, i2 - 1)
  68. '                If s = 1 Then Call AZE(ar, x, j2, i, i2 - 1)
  69.             End If
  70.             If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j)
  71.         Loop
  72.         j = j2
  73.     Next
  74.    
  75.     i = l: t = ar(x(i), j2): i2 = i
  76.     Do
  77.         Do
  78.             i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j2) <> t Then Exit Do
  79.         Loop
  80.         If i2 - i > 1 Then Call QSort(x, i, i2 - 1)
  81.         If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j2)
  82.     Loop
  83.    
  84.     szpx2 = x
  85. '    szpx = szbr(ar, x, h)
  86. End Function
复制代码

回复

举报

香川群子

TA的精华主题

TA的得分主题
 楼主| 发表于 2015-12-8 16:08 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
方法-1代码：

  1. Sub szpx_1()
  2.     Dim ar, br, nr, sr, h&, i&, i2&, j2&, l&, l2&, m&, u&, u2&, tm#, tms#
  3.     tms = Timer
  4.     Debug.Print vbCr; "szpx_1"
  5.    
  6.     tm = Timer
  7.     Sheet1.Activate
  8.     m = [a3].End(4).Row
  9.     ar = [a1].Resize(m, 103)
  10.     h = 2
  11.     For i = h + 1 To m
  12.         ar(i, 1) = Val(ar(i, 1))
  13.     Next
  14.     Debug.Print Format(Timer - tm, "0.00s ") & "Get ar"
  15.    
  16.     tm = Timer
  17.     sr = Array(102, 2, 103, 2, 1, 2, 2, 1)
  18.     nr = szpx1(ar, 2, sr)
  19.     Debug.Print Format(Timer - tm, "0.00s ") & "Sort"
  20.    
  21.     tm = Timer
  22.     l = LBound(nr): u = UBound(nr)
  23.     l2 = LBound(ar, 2): u2 = UBound(ar, 2)
  24.     ReDim br(l - h To u, l2 To u2)
  25.     For i = 1 To h
  26.         For j2 = l2 To u2
  27.             br(l - h + i - 1, j2) = ar(LBound(ar) + i - 1, j2)
  28.         Next
  29.     Next
  30.     For i = l To u
  31.         i2 = nr(i)
  32.         For j2 = l2 To u2
  33.             br(i, j2) = ar(i2, j2)
  34.         Next
  35.     Next
  36.     Debug.Print Format(Timer - tm, "0.00s ") & "Output"
  37.    
  38.     tm = Timer
  39.     Sheet2.Activate
  40.     [a1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
  41.     Debug.Print Format(Timer - tm, "0.00s ") & "Output"
  42.    
  43.     Debug.Print Format(Timer - tms, "0.00s ") & "Total"
  44.     MsgBox Format(Timer - tms, "0.00s ") & u - l + 1
  45. End Sub
  46. Function szpx1(ar, h&, ParamArray sr()) 'by kagawa 2015/12/4-12/7
  47.     Dim br, y, sr2, i&, i2&, i3&, i4&, j&, j2&, k&, l&, u&, s&, t
  48.    
  49.     l = LBound(ar) + h: u = UBound(ar)
  50.     ReDim x&(l To u), z(l To u + 1) As Boolean
  51.     For i = l To u
  52.         x(i) = i
  53.     Next
  54.     z(u + 1) = True
  55.    
  56.     If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr
  57.     j = sr2(0): If sr2(1) Mod 2 Then Call QSort1(ar, x, j, l, u) Else Call QSort2(ar, x, j, l, u)
  58.     For i = l To u
  59.         If ar(x(i), j) = "" Then u = i - 1: ReDim Preserve x&(l To u):  z(u + 1) = True: Exit For
  60.     Next
  61. '    If sr2(1) = 1 Then Call AZE(ar, x, j, l, u)
  62.     For k = 2 To UBound(sr2) Step 2
  63.         j2 = sr2(k): s = sr2(k + 1)
  64.         i = l: t = ar(x(i), j): i2 = i
  65.         Do
  66.             Do
  67.                 i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then z(i2) = True: Exit Do
  68.             Loop
  69.             If i2 - 1 > i Then
  70.                 If s Mod 2 Then Call QSort1(ar, x, j2, i, i2 - 1) Else Call QSort2(ar, x, j2, i, i2 - 1)
  71. '                If s = 1 Then Call AZE(ar, x, j2, i, i2 - 1)
  72.             End If
  73.             If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j)
  74.         Loop
  75.         j = j2
  76.     Next
  77.    
  78.     i = l: t = ar(x(i), j2): i2 = i
  79.     Do
  80.         Do
  81.             i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j2) <> t Then Exit Do
  82.         Loop
  83.         If i2 - i > 1 Then Call QSort(x, i, i2 - 1)
  84.         If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j2)
  85.     Loop
  86.    
  87.     szpx1 = x
  88. End Function
复制代码
回复

举报

香川群子

TA的精华主题

TA的得分主题
 楼主| 发表于 2015-12-8 16:08 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
这部分是两者通用的，也是必须的。
  1. Function QSort(x, l&, u&) 'A-Z QuickSort
  2.     Dim i&, j&, n&, r&
  3.     i = l: j = u: r = x((l + u) \ 2)
  4.     While i < j
  5.         While x(i) < r: i = i + 1: Wend 'A-Z
  6.         While x(j) > r: j = j - 1: Wend 'A-Z
  7.         If i <= j Then: n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
  8.     Wend
  9.     If l < j Then Call QSort(x, l, j)
  10.     If i < u Then Call QSort(x, i, u)
  11. End Function
  12. Function QSort1(ar, x, j2&, l&, u&) 'A-Z QuickSort
  13.     Dim i&, j&, n&, r
  14.     i = l: j = u: r = ar(x((l + u) \ 2), j2)
  15.     While i < j
  16.         While ar(x(i), j2) < r And i < u: i = i + 1: Wend   'A-Z
  17.         While ar(x(j), j2) > r And j > l: j = j - 1: Wend   'A-Z
  18.         If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
  19.     Wend
  20.     If l < j Then Call QSort1(ar, x, j2, l, j)
  21.     If i < u Then Call QSort1(ar, x, j2, i, u)
  22. End Function
  23. Function QSort2(ar, x, j2&, l&, u&) 'Z-A QuickSort
  24.     Dim i&, j&, n&, r
  25.     i = l: j = u: r = ar(x((l + u) \ 2), j2)
  26.     While i < j
  27.         While ar(x(i), j2) > r And i < u: i = i + 1: Wend 'Z-A
  28.         While ar(x(j), j2) < r And j > l: j = j - 1: Wend 'Z-A
  29.         If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
  30.     Wend
  31.     If l < j Then Call QSort2(ar, x, j2, l, j)
  32.     If i < u Then Call QSort2(ar, x, j2, i, u)
  33. End Function
  34. Function AZE(ar, x, j, l&, u&)
  35.     Dim i&, i2&, y
  36.     For i = l To u
  37.         If ar(x(i), j) <> "" Then
  38.             y = x
  39.             For i2 = l To i - 1
  40.                 x(u - i + i2 + 1) = y(i2)
  41.             Next
  42.             For i2 = i To u
  43.                 x(i2 - i + l) = y(i2)
  44.             Next
  45.             Exit For
  46.         End If
  47.     Next
  48. End Function

复制代码
回复

举报

t13564865256

TA的精华主题

TA的得分主题
发表于 2015-12-8 16:46 | 显示全部楼层
[广告] ★ExcelHome默写助手 - 不用妈妈陪的默写神器 · Word/WPS插件 · 自定义默写单 · 自定义描红字帖★
香川老师，有终极版本的稳定排序算法了吗？期待依旧，长期关注。
回复

举报

香川群子

TA的精华主题

TA的得分主题
 楼主| 发表于 2015-12-8 17:12 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
QuickSort排序部分做了改进……当个数较少<36个元素时，直接采用插入排序。而非反复递归。

  1. Function QSort(x, l&, u&) 'A-Z QuickSort
  2.     Dim i&, j&, n&, r&
  3.     If u - l < 36 Then
  4.         For i = l + 1 To u
  5.             r = x(i)
  6.             For j = i - 1 To l Step -1
  7.                 If x(j) > r Then x(j + 1) = x(j) Else Exit For
  8.             Next
  9.             x(j + 1) = r
  10.         Next
  11.     Else
  12.         i = l: j = u: r = x((l + u) \ 2)
  13.         While i < j
  14.             While x(i) < r: i = i + 1: Wend 'A-Z
  15.             While x(j) > r: j = j - 1: Wend 'A-Z
  16.             If i <= j Then: n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
  17.         Wend
  18.         If l < j Then Call QSort(x, l, j)
  19.         If i < u Then Call QSort(x, i, u)
  20.     End If
  21. End Function
  22. Function QSort1(ar, x, j2&, l&, u&) 'A-Z QuickSort
  23.     Dim i&, j&, n&, r
  24.     If u - l < 36 Then
  25.         For i = l + 1 To u
  26.             r = ar(x(i), j2): n = x(i)
  27.             For j = i - 1 To l Step -1
  28.                 If ar(x(j), j2) > r Then x(j + 1) = x(j) Else Exit For
  29.             Next
  30.             x(j + 1) = n
  31.         Next
  32.     Else
  33.         i = l: j = u: r = ar(x((l + u) \ 2), j2)
  34.         While i < j
  35.             While ar(x(i), j2) < r And i < u: i = i + 1: Wend   'A-Z
  36.             While ar(x(j), j2) > r And j > l: j = j - 1: Wend   'A-Z
  37.             If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
  38.         Wend
  39.         If l < j Then Call QSort1(ar, x, j2, l, j)
  40.         If i < u Then Call QSort1(ar, x, j2, i, u)
  41.     End If
  42. End Function
  43. Function QSort2(ar, x, j2&, l&, u&) 'Z-A QuickSort
  44.     Dim i&, j&, n&, r
  45.     If u - l < 36 Then
  46.         For i = l + 1 To u
  47.             r = ar(x(i), j2): n = x(i)
  48.             For j = i - 1 To l Step -1
  49.                 If ar(x(j), j2) < r Then x(j + 1) = x(j) Else Exit For
  50.             Next
  51.             x(j + 1) = n
  52.         Next
  53.     Else
  54.         i = l: j = u: r = ar(x((l + u) \ 2), j2)
  55.         While i < j
  56.             While ar(x(i), j2) > r And i < u: i = i + 1: Wend 'Z-A
  57.             While ar(x(j), j2) < r And j > l: j = j - 1: Wend 'Z-A
  58.             If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1
  59.         Wend
  60.         If l < j Then Call QSort2(ar, x, j2, l, j)
  61.         If i < u Then Call QSort2(ar, x, j2, i, u)
  62.     End If
  63. End Function
复制代码
回复

举报

香川群子

TA的精华主题

TA的得分主题
 楼主| 发表于 2015-12-8 17:13 | 显示全部楼层
[广告] ★ExcelHome默写助手 - 不用妈妈陪的默写神器 · Word/WPS插件 · 自定义默写单 · 自定义描红字帖★
t13564865256 发表于 2015-12-8 16:46
香川老师，有终极版本的稳定排序算法了吗？期待依旧，长期关注。

顶楼的应该是了。

当然，具体使用时可以做适当修改，以便适应更多情况。

目前实测速度还可以。

回复

举报

香川群子

TA的精华主题

TA的得分主题
 楼主| 发表于 2015-12-8 21:04 | 显示全部楼层
[广告] ★Excel Home云课堂 - 专业的职场技能充电站★         ★Excel三大利器★        ★ 笨办法学VBA全系列★
含数据的文件太大。删去大部分数据后上传附件。
有效直接排序后输出.rar (616.51 KB, 下载次数: 371)



评分

1

查看全部评分

回复

举报

qx-liuwx

TA的精华主题

TA的得分主题
发表于 2015-12-8 21:42 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
本帖最后由 qx-liuwx 于 2015-12-8 21:58 编辑
香川群子 发表于 2015-12-8 21:04
含数据的文件太大。删去大部分数据后上传附件。


飞一般的感觉！！！

按香川老师最后的附件！有图为证。
越来越感到自己的水平………
谢谢老师热心的帮助！！

回复

举报

qx-liuwx

TA的精华主题

TA的得分主题
发表于 2015-12-8 22:00 | 显示全部楼层
[广告] ★ExcelHome默写助手 - 不用妈妈陪的默写神器 · Word/WPS插件 · 自定义默写单 · 自定义描红字帖★
本帖最后由 qx-liuwx 于 2015-12-10 07:43 编辑

论坛还是有问题，上传不了图片及附件？
2015-12-08_21-37.png
回复

举报

香川群子

TA的精华主题

TA的得分主题
 楼主| 发表于 2015-12-9 09:31 | 显示全部楼层
[广告] ★Excel Home云课堂 - 专业的职场技能充电站★         ★Excel三大利器★        ★ 笨办法学VBA全系列★
qx-liuwx 发表于 2015-12-8 22:00
论坛还是有问题，上传不了图片及附件？

从同文件夹的Data.txt文件中提取80万有效数据，然后整理输出的代码附件。


DataSort4.zip

48.76 KB, 下载次数: 234

评分

1

查看全部评分

回复

举报

下一页 »
1234567下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-5-22 23:05 , Processed in 0.035810 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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