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

香川群子 · 发表于 2015-12-4 15:08

本帖最后由香川群子于 2015-12-7 19:38 编辑

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

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

示例代码如下：

Sub test1()
Dim ar, sr, sr2, i&, j&, tms#
'假设待排序原始数据是在A1开始的多行、7列区域中
sr = Array(1, 3, 5, 7) '需要排序的列的权重顺序
sr2 = Array(1, 2, 2, 1) '需要排序的列的升降顺序(1为升序、2为降序)
Application.ScreenUpdating = False '禁止刷屏
For j = UBound(sr) To 0 Step -1 '逆序循环
[a1].Sort [a1].Offset(, sr(j) - 1), sr2(j) '每次排序1列
Next
Application.ScreenUpdating = True
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, 下载次数: 1553)

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

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

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

在此深表敬意。（抄袭代码就是致敬！呵呵。）
2015/12/7

香川群子 · 发表于 2015-12-4 15:10

本帖最后由香川群子于 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种写法，比较清楚一点吧。

Sub test1() '【二维数组多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

复制代码

香川群子 · 发表于 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值内容相同部分、还需按原始顺序升序排序）

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

复制代码

香川群子 · 发表于 2015-12-4 15:14

本帖最后由香川群子于 2015-12-7 19:54 编辑

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

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

复制代码

qx-liuwx · 发表于 2015-12-4 15:18

香川群子发表于 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-5 10:21

本帖最后由百度不到去谷歌于 2015-12-5 10:24 编辑

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

蓝桥玄霜 · 发表于 2015-12-5 11:50

香川群子发表于 2015-12-4 15:10
排序核心代码，即QuickSort递归排序算法，
增加了升序/降序的选择参数。为考虑运行速度，实际上是升序/降 ...

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

香川群子 · 发表于 2015-12-5 16:58

本帖最后由香川群子于 2015-12-7 20:00 编辑

蓝桥玄霜发表于 2015-12-5 11:50
请群子介绍一下Sort2的所有参数，这里只有升序/降序的选择参数s

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

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

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

复制代码

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

Function szbr(ar, nr, h&) 'output result
'按最终排序结果的nr数组Index值、转换为排序后二维数组结果的过程
'参数ar=排序前二维数组 (在所有排序过程中始终不变、仅被引用数据)
'参数nr=排序历史结果顺序、即排序结果对应的原始数组Index值
'参数h=不参与排序的标题行的行数值。如h=0则为无标题行、可任意设置h<=u-l+1。
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值对应的行位置i2
For j2 = l2 To u2 '循环遍历列
br(i, j2) = ar(i2, j2) '按排序后的Index值i2引用原始数据写入新数组br对应的i行
Next
Next
szbr = br '输出整理后结果
End Function

复制代码

香川群子 · 发表于 2015-12-5 18:41

本帖最后由香川群子于 2015-12-7 20:04 编辑

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

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

香川群子 · 发表于 2015-12-5 18:46

qx-liuwx 发表于 2015-12-4 15:18
老师辛苦了。
因我不会修改老师的代码，未能用到我的实例。
我的实例是见截图

很想帮忙。

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

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

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分