ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2015-12-4 15:08 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:排序
本帖最后由 香川群子 于 2015-12-7 19:38 编辑

一般说,由Excel中的单元格区域数据对象构成的二维数组,可以直接使用工作表排序方法。
不仅速度快,而且无需读入、写出操作。

但是,默认工作表排序方法一次只能使用3个key、所以如果有较多key需要排序时,
可以使用VBA循环代码,一次排1列,逆序循环排序后得到结果。
【注意必须逆序操作,即、权重最小的列第1个排序,而权重最大的列必须最后一个排序。】
这个和我们通常的习惯是相反的,需要注意。

示例代码如下:
  1. Sub test1()
  2.     Dim ar, sr, sr2, i&, j&, tms#

  3.     '假设待排序原始数据是在A1开始的多行、7列区域中
  4.     sr = Array(1, 3, 5, 7)  '需要排序的列的权重顺序
  5.     sr2 = Array(1, 2, 2, 1) '需要排序的列的升降顺序(1为升序、2为降序)
  6.    
  7.     Application.ScreenUpdating = False '禁止刷屏
  8.         For j = UBound(sr) To 0 Step -1 '逆序循环
  9.             [a1].Sort [a1].Offset(, sr(j) - 1), sr2(j) '每次排序1列
  10.         Next
  11.     Application.ScreenUpdating = True
  12.    
  13.    End Sub
复制代码


这样已经很好了。

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

另外,如果是超过65536行甚至几十万、几百万的数据需要排序,
那工作表方法就不能用了,读写数据就需大量时间。

因此,虽然不是很常用,但还是需要一种直接对VBA内存数组进行排序的算法。

VBA排序算法有很多,但基本上都是一维数组排序。
即使简单改写一下能用于二维数组,但对于稳定的多key排序,就无法解决。

因为,稳定排序的冒泡算法速度非常之慢,而速度较快的快速排序是不稳定排序算法,
所以多key排序的结果就会出错。

有鉴于此,我在高手提示下,用简单的VBA代码补充完善了QuickSort算法的稳定排序方法,
因此,已经可以进行二维数组的多key稳定排序了。

代码如附件。
2015/12/7彻底更新附件。
二维数组多key稳定排序 Multi-Key Stable Sort_kagawa.rar (22.25 KB, 下载次数: 1494)



附件更新、加入了必要的注释、以及参数的概略说明。
同时,写了2个test示例代码,分别说明对工作表区域读入二维数组以后的多key稳定排序,
以及直接对VBA内存二维数组进行多key稳定排序的使用方法。

我原创的算法虽然结果是正确的,但速度效率很低。
【因为简单模仿工作表超过3key的多key排序时、需采取倒序排序的方法,因此误入歧途,效率很低】

所以,现在的代码,已经是按照Zamyi大侠的基本算法进行。(仅仅增加了最后的稳定性排序、以及空值移动到最后的算法)

在此深表敬意。(抄袭代码就是致敬!呵呵。)
2015/12/7



评分

11

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-12-4 15:10 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 香川群子 于 2015-12-7 19:47 编辑

该排序方法写成了Function形式,可以一句代码引用:

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

'第1参数ar 为待排序二维数组、第2参数h 为不参与排序的标题行的行数
'从第3个参数开始交替写入key、Sort值的排序参数。


也可以这样、把排序参数事先写入数组sr、然后直接引用:

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

我推荐第2种写法,比较清楚一点吧。





  1. Sub test1() '【二维数组多key稳定排序】的应用示例
  2.     Dim ar, br, nr, sr, h&, i&, j&, m&, n&, r&, tms#
  3.    
  4.     m = 20000: n = 7
  5.     ReDim a(1 To m, 1 To n)
  6.     For i = 1 To m
  7.         a(i, 1) = i
  8.         For j = 2 To n
  9.             r = Int(Rnd * 10): If r Then a(i, j) = r
  10.         Next
  11.     Next
  12.     ar = a '以上生成m行n列的VBA内存二维数组
  13.    
  14. '    ar = [k1].CurrentRegion.Value '也可直接读取工作表区域得到二维数组
  15.    
  16.     sr = Array(3, 1, 5, 2, 7, 1) '按权重优先顺序key、Sort值交替排列的一维数组。key为列序号、Sort值:1升序、2降序
  17. '    sr = Array(3, -1, 5, 2, 7, -1)'Sort值=-1时,升序并且空值会在最前面。(Sort=1时按工作表排序方法空值排在最后)
  18.                                    'Sort值=2时、降序而空值自然会在最后。
  19.     tms = Timer
  20.     nr = szpx(ar, 0, sr) '第1参数为待排序二维数组、第2参数为不参与排序的标题行的行数
  21.                          '第3参数为按权重优先顺序key、Sort值交替排列的一维数组。
  22.     Debug.Print "Sort1: " & Format(Timer - tms, "0.00s ") & "Sort"
  23.    
  24.    
  25. '    nr = szpx(ar, 0, 3, 1, 5, 2, 7, 1) '也可这样写入参数。从第3个参数开始交替写入key、Sort值。推荐第1种写法。
  26.    
  27. '    Exit Sub
  28. '    下面是返回排序后数组结果?并输出到工作表的代码
  29.     br = szbr(ar, nr, 0): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
  30. End Sub
复制代码

评分

3

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-12-4 15:13 | 显示全部楼层
本帖最后由 香川群子 于 2015-12-7 19:51 编辑

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值。

该过程中增加了对空白单元格放到最后的处理代码
最后增加了稳定排序的处理。(最后的key值内容相同部分、还需按原始顺序升序排序)


  1. Function szpx(ar, h&, ParamArray sr()) 'by kagawa 2015/12/4-12/7 主要参考借鉴了Zamyi大侠的二维数组多key排序算法
  2.     '第1参数ar:为待排序二维数组、第2参数h:为不参与排序的标题行的行数
  3.     '第3参数sr:为按权重优先顺序key、Sort值交替排列的一维数组、或以逗号分隔直接写入Key、Sort值。
  4.    
  5.     Dim br, y, sr2, i&, i2&, i3&, i4&, j&, j2&, k&, l&, u&, s&, t
  6.    
  7.     l = LBound(ar) + h: u = UBound(ar) '获取数组起始、结束位置
  8.     ReDim x&(l To u), z(l To u + 1) As Boolean '定义存放Index序号的数组x、标记段落结束位置的数组z
  9.     For i = l To u
  10.         x(i) = i 'Index赋值为数组行序号、这以后排序就只需改变这个Index位置、原始数组无需改变
  11.     Next
  12.     z(u + 1) = True '标记最后结束位置
  13.    
  14.     If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr '判断第3参数是数组、还是多Key、Sort值序列
  15.     j = sr2(0): If sr2(1) Mod 2 Then Call QuickSort1(ar, x, j, l, u) Else Call QuickSort2(ar, x, j, l, u)
  16.     '按key1先进行QuickSort排序
  17.     If sr2(1) = 1 Then Call AZE(ar, x, j, l, u) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
  18.    
  19.     For k = 2 To UBound(sr2) Step 2 '接着循环继续key2以后的排序
  20. '        br = szbr(ar, x, h): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br
  21.         j2 = sr2(k): s = sr2(k + 1) '读取排序key的列序号j2 和Sort值s
  22.         i = l: t = ar(x(i), j): i2 = i 'Do循环检查是否前key相同【注意,仅仅前key相同部分需要继续排序】
  23.         Do
  24.             Do
  25.                 i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then z(i2) = True: Exit Do
  26.                 '递增检查如果到了前前key的结束位置、或前key不同则停止退出Do循环
  27.             Loop
  28.             If i2 - i > 1 Then '如果间隔>1 则本key需要排序处理【注意排序区间是小范围i,i2-1】
  29.                 If s Mod 2 Then Call QuickSort1(ar, x, j2, i, i2 - 1) Else Call QuickSort2(ar, x, j2, i, i2 - 1)
  30.                 If s = 1 Then Call AZE(ar, x, j2, i, i2 - 1) '如果Sort值=1则需要调用AZE过程、把空值移动到最后
  31.             End If
  32.             If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续从i2重新开始Do循环
  33.         Loop
  34.         j = j2 '更新前key列位置j
  35.     Next
  36.    
  37.     '全部排序循环结束后、为保证最后的排序稳定性、检查最后的key值相同时必须按Index值排序。
  38.     i = l: t = ar(x(i), j): i2 = i
  39.     Do
  40.         Do
  41.             i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then Exit Do '检查方法相同
  42.         Loop
  43.         If i2 - i > 1 Then Call QuickSort(x, i, i2 - 1) '如果间隔>1 则Index值需要排序处理
  44.         If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续
  45.     Loop

  46.     szpx = x '多key稳定排序处理结束、返回排序结果的Index数组x
  47. '    szpx = szbr(ar, x, h) '或返回按排序后Index顺序引用返回的排序结果数组br
  48. End Function
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-12-4 15:14 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 香川群子 于 2015-12-7 19:54 编辑

所有具体的排序方法,都是QuickSort递归排序算法
只是按排序对象不同、以及升序、降序不同,复制了3个排序过程。但是其基本排序原理,都是一样的。

  1. Function QuickSort(x, l&, u&) 'A-Z QuickSort '最后稳定排序时对相同key的Index值升序排序
  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 QuickSort(x, l, j)
  10.     If i < u Then Call QuickSort(x, i, u)
  11. End Function
  12. Function QuickSort1(ar, x, j2&, l&, u&) 'A-Z QuickSort 按原数组j2列对应内容进行升序排序
  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 QuickSort1(ar, x, j2, l, j)
  21.     If i < u Then Call QuickSort1(ar, x, j2, i, u)
  22. End Function
  23. Function QuickSort2(ar, x, j2&, l&, u&) 'Z-A QuickSort 按原数组j2列对应内容进行降序排序
  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 QuickSort2(ar, x, j2, l, j)
  32.     If i < u Then Call QuickSort2(ar, x, j2, i, u)
  33. End Function
复制代码


TA的精华主题

TA的得分主题

发表于 2015-12-4 15:18 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
香川群子 发表于 2015-12-4 15:14
最后实际上而二维多key排序代码,实际上就很简单了。

     nr = x

老师辛苦了。
因我不会修改老师的代码,未能用到我的实例。
我的实例是见截图
完全是按录制excel排序的宏代码如下,看看怎样老师您的的代码如何才能适用于该情况,谢谢!
    rra = Cells(Rows.Count, "cy").End(3).Row
    ActiveWorkbook.Worksheets("B点").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("B点").Sort.SortFields.Add Key:=Range("cy4:cy" & rra), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("B点").Sort.SortFields.Add Key:=Range("A4:A" & rra), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    ActiveWorkbook.Worksheets("B点").Sort.So老师辛苦了。
因我不会修改老师的代码,未能用到我的实例。
我的实例是见截图
完全是按录制excel排序的宏代码如下,看看怎样老师您的的代码如何才能适用于该情况,谢谢!
    rra = Cells(Rows.Count, "cy").End(3).Row
    ActiveWorkbook.Worksheets("B点").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("B点").Sort.SortFields.Add Key:=Range("cy4:cy" & rra), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("B点").Sort.SortFields.Add Key:=Range("A4:A" & rra), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    ActiveWorkbook.Worksheets("B点").Sort.SortFields.Add Key:=Range("C4:C" & rra), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("B点").Sort
        .SetRange Range("A4:cy" & rra)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
将[a4:cx726812]按cy/a/c三个关键字排序,用工作表的是18秒左右,这还可以接受。
但如果是在代码中有循环中来完成这个排序,则在不断循环次数的增加、每次的排序时间变得越来越长,慢到难于接受rtFields.Add Key:=Range("C4:C" & rra), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("B点").Sort
        .SetRange Range("A4:cy" & rra)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

将[a4:cx726812]按cy/a/c三个关键字排序,用工作表的是18秒左右,这还可以接受。
但如果是在代码中有循环中来完成这个排序,则在不断循环次数的增加、每次的排序时间变得越来越长,慢到难于接受
2015-12-04_15-01.png

TA的精华主题

TA的得分主题

发表于 2015-12-5 10:21 | 显示全部楼层
本帖最后由 百度不到去谷歌 于 2015-12-5 10:24 编辑

还有一种就是借助recordset排序 好处是可以通过字段访问 对数组要做筛选 汇总等操作又sql比较熟悉的可以采用写入记录集后用sql操作比较方便
不过速度肯定就比这差远了  收纳到工具包了  多谢女侠

TA的精华主题

TA的得分主题

发表于 2015-12-5 11:50 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
香川群子 发表于 2015-12-4 15:10
排序核心代码,即QuickSort递归排序算法,
增加了升序/降序的选择参数。为考虑运行速度,实际上是升序/降 ...

请群子介绍一下Sort2的所有参数,这里只有升序/降序的选择参数s

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-12-5 16:58 | 显示全部楼层
本帖最后由 香川群子 于 2015-12-7 20:00 编辑
蓝桥玄霜 发表于 2015-12-5 11:50
请群子介绍一下Sort2的所有参数,这里只有升序/降序的选择参数s

最后增加了升序排序时,把数组中空白内容(""或Empty)放置到末尾最后的处理过程。这是参考工作表排序结果的做法。

如果不需要这么做,即允许升序排序时空白内容排列在最前面,则只需把Sort参数=-1即可忽略此移动过程。
而如果是降序,则空白内容本来就会在最后,无需特殊处理。

  1. Function AZE(ar, x, j, l&, u&) 'Sort值=1时、把排序完成后的空值移动到最后
  2.     Dim i&, i2&, y
  3.     For i = l To u
  4.         If ar(x(i), j) <> "" Then '检查直到非空位置时停止
  5.             y = x '复制Index数组x到y
  6.             For i2 = l To i - 1
  7.                 x(u - i + i2 + 1) = y(i2) '前面的空值对应Index值移动到最后
  8.             Next
  9.             For i2 = i To u
  10.                 x(i2 - i + l) = y(i2) '后面的非空值对应Index值移动到前面
  11.             Next
  12.             Exit For
  13.         End If
  14.     Next
  15. End Function
复制代码


另外一个过程,是根据排序后Index值顺序、引用原数组得到最终的排序好的二维数组。
【但是,一般在VBA内存数组中进行排序后,如果无需输出排序后二维数组到工作表,而仅需在VBA中引用,则不需要此过程】

  1. Function szbr(ar, nr, h&) 'output result
  2.     '按最终排序结果的nr数组Index值、转换为排序后二维数组结果的过程
  3.     '参数ar=排序前二维数组 (在所有排序过程中始终不变、仅被引用数据)
  4.     '参数nr=排序历史结果顺序、即排序结果对应的原始数组Index值
  5.     '参数h=不参与排序的标题行的行数值。如h=0则为无标题行、可任意设置h<=u-l+1。
  6.    
  7.     Dim br, i&, i2&, j2&, l&, l2&, u&, u2&
  8.     l = LBound(ar) + h: u = UBound(ar) '行标起始、结束范围
  9.     l2 = LBound(ar, 2): u2 = UBound(ar, 2) '列标起始、结束范围
  10.     br = ar '复制原始数组
  11.     For i = l To u '循环遍历行
  12.         i2 = nr(i) '获取排序后的行Index值对应的行位置i2
  13.         For j2 = l2 To u2 '循环遍历列
  14.             br(i, j2) = ar(i2, j2) '按排序后的Index值i2引用原始数据写入新数组br对应的i行
  15.         Next
  16.     Next
  17.     szbr = br '输出整理后结果
  18. End Function
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-12-5 18:41 | 显示全部楼层
本帖最后由 香川群子 于 2015-12-7 20:04 编辑

顶楼附件已经更新。
再次更新附件。

二维数组多key稳定排序_kagawa.rar (22.2 KB, 下载次数: 517)

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-12-5 18:46 | 显示全部楼层
qx-liuwx 发表于 2015-12-4 15:18
老师辛苦了。
因我不会修改老师的代码,未能用到我的实例。
我的实例是见截图

很想帮忙。

但你提问题的方式不对。
只看附件,无法知道你之前的过程。

希望你从最初的数据开始提出问题。
因为你之前的很多做法,可能效率非常低,从最后部分优化,往往是无效果的。

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 14:31 , Processed in 0.060880 second(s), 13 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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