基于归并排序的稳定二维数据表多key排序学习

aoe1981

近来很长时间在折腾“一维数据排序”算法学习，见下帖：
排序算法学习
http://club.excelhome.net/thread-1501469-1-1.html
(出处: ExcelHome技术论坛)


一天，有坛友提出以下建议：



我傻傻地有点心动了，便又看了看香川大侠的神帖：
VBA内存二维数组对象的多key稳定排序算法
http://club.excelhome.net/thread-1245495-1-1.html
(出处: ExcelHome技术论坛)


为了达到“多key稳定排序”，我选择的排序算法是稳定而快速的“归并排序”。快速排序虽然效率更高，但让其稳定的办法我不太清楚，而且我不太喜欢在原数据表中增加“稳定列”，比如新添具有唯一值的“序号列”。

事实上，我下面的附件中确实是增加了“序号列”的，如图：



但这样做，不是在排序过程中偷偷使用，而是为了便于将我的代码排序结果与Excel工作表自带排序结果对比，检验其正确性。删掉附件中的“序号列”是完全OK的，只不过比较结果是否一致时，恐怕得用连接所有字段值再比较的办法，比较烦。

我对我使用“归并排序”作为底层排序算法的“稳定性”是充满自信的，但是不承想结果却与工作表排序不完全一样。

我的排序key值选择是：



其中1表示升序，2表示降序。

极个别不一致的地方如下图：



起初我以为是“工作表排序”是“不稳定”的，在接下来的仔细分析中，发现我的结果和工作表排序的结果都是正确的，原因见下图：





看到了没有？在工作表中："女"<"男"=FALSE，在VBA中："女"<"男"=True，谁让Excel如此矛盾和纠结呢？

找到原因后，我便放心了，可以发帖了。放心的不是说自己多优秀，而是其正确性。

主程序代码如下：

1. Public Sub Main() '主程序
   
2.     Dim arr(), crr(), tj(), rng As Range, sh$, xb&, n&, m&, i&, d As Object, di, sr&(), t!
   
3.     t = Timer()
   
4.     Set rng = Sht1.Range("a1").CurrentRegion
   
5.     If rng.Count < 2 Then MsgBox "源数据错误。", , "by aoe1981 2019/10/06": Exit Sub
   
6.     arr = rng.Value
   
7.     Set rng = Nothing
   
8.     n = UBound(arr, 1)
   
9.     m = UBound(arr, 2)
   
10.     With Sht2
    
11.         sh = .Range("a2").Value
    
12.         tj = .Range("c2:d" & m + 1).Value
    
13.     End With
    
14.     If sh = "是" And n = 1 Then MsgBox "源数据只有标题行。", , "by aoe1981 2019/10/06": Exit Sub
    
15.     If sh = "是" Then xb = 1 Else xb = 2
    
16.     Set d = CreateObject("scripting.dictionary")
    
17.     For i = 1 To m
    
18.         If tj(i, 1) <> "" Then d(tj(i, 1)) = tj(i, 2) '排序条件去重
    
19.     Next i
    
20.     Erase tj
    
21.     ReDim sr&(1 To d.Count * 2)
    
22.     i = 1
    
23.     For Each di In d.keys '排序条件转换格式与香川接轨
    
24.         sr(2 * i - 1) = di
    
25.         sr(2 * i) = d(di)
    
26.         i = i + 1
    
27.     Next di
    
28.     Set d = Nothing
    
29.     crr = Multi_Key_Sort(arr, xb, sr) '第二参数不一样，表示排序记录开始的下标
    
30.     With Sht3
    
31.         .Cells.ClearContents
    
32.         .Range("a1").Resize(n, m).Value = crr
    
33.         .Cells.EntireColumn.AutoFit
    
34.     End With
    
35.     MsgBox "用时：" & Timer() - t & "秒", , "by aoe1981 2019/10/06"
    
36. End Sub

复制代码

排序函数代码如下：

1. Option Explicit
   
2. Dim brr1(), brr2(), crr1(), crr2()
   
3. Public Function Multi_Key_Sort(arr1(), xb1&, sr1&())
   
4.     Dim n&, m&, i&, j&
   
5.     n = UBound(arr1, 1)
   
6.     m = UBound(arr1, 2)
   
7.     ReDim brr1(xb1 To n), brr2(xb1 To n), crr1(xb1 To n), crr2(xb1 To n)
   
8.     For j = xb1 To n
   
9.         brr1(j) = j '记录序号
   
10.     Next j
    
11.     For i = UBound(sr1) To 2 Step -2
    
12.         For j = xb1 To n
    
13.             brr2(j) = arr1(brr1(j), sr1(i - 1)) '排序字段
    
14.         Next j
    
15.         If sr1(i) = 1 Then
    
16.             Call MergeSort1(xb1, n)
    
17.         ElseIf sr1(i) = 2 Then
    
18.             Call MergeSort2(xb1, n)
    
19.         End If
    
20.     Next i
    
21.     ReDim arr2(1 To n, 1 To m)
    
22.     For i = xb1 To n
    
23.         For j = 1 To m
    
24.             arr2(i, j) = arr1(brr1(i), j)
    
25.         Next j
    
26.     Next i
    
27.     If xb1 > 1 Then '排序数据不含标题行时写入标题行
    
28.         For j = 1 To m
    
29.             arr2(1, j) = arr1(1, j)
    
30.         Next j
    
31.     End If
    
32.     Multi_Key_Sort = arr2
    
33.     Erase brr1, brr2, crr1, crr2
    
34. End Function
    
35. Public Sub MergeSort1(l&, r&) '归并排序（升序）
    
36.     If l = r Then Exit Sub
    
37.     Dim c&
    
38.     c = Int((l + r) / 2)
    
39.     Call MergeSort1(l, c)
    
40.     Call MergeSort1(c + 1, r)
    
41.     If brr2(c) > brr2(c + 1) Then Call DG1(l, c, r)
    
42. End Sub
    
43. Public Sub DG1(l&, c&, r&)
    
44.     Dim l1&, r1&, i&, j&
    
45.     l1 = l
    
46.     r1 = c + 1
    
47.     i = l
    
48.     j = l
    
49.     While l1 <= c And r1 <= r '从两端依次取出最小的元素装入临时数组
    
50.         If brr2(l1) <= brr2(r1) Then
    
51.             crr1(i) = brr1(l1)
    
52.             crr2(i) = brr2(l1)
    
53.             i = i + 1
    
54.             l1 = l1 + 1
    
55.         Else
    
56.             crr1(i) = brr1(r1)
    
57.             crr2(i) = brr2(r1)
    
58.             i = i + 1
    
59.             r1 = r1 + 1
    
60.         End If
    
61.     Wend
    
62.     While r1 <= r '先装入右端较小剩余
    
63.         crr1(i) = brr1(r1)
    
64.         crr2(i) = brr2(r1)
    
65.         i = i + 1
    
66.         r1 = r1 + 1
    
67.     Wend
    
68.     While l1 <= c '再装入左端较大剩余
    
69.         crr1(i) = brr1(l1)
    
70.         crr2(i) = brr2(l1)
    
71.         i = i + 1
    
72.         l1 = l1 + 1
    
73.     Wend
    
74.     While j <= r
    
75.         brr1(j) = crr1(j)
    
76.         brr2(j) = crr2(j)
    
77.         j = j + 1
    
78.     Wend
    
79. End Sub
    
80. Public Sub MergeSort2(l&, r&) '归并排序（降序）
    
81.     If l = r Then Exit Sub
    
82.     Dim c&
    
83.     c = Int((l + r) / 2)
    
84.     Call MergeSort2(l, c)
    
85.     Call MergeSort2(c + 1, r)
    
86.     If brr2(c) < brr2(c + 1) Then Call DG2(l, c, r)
    
87. End Sub
    
88. Public Sub DG2(l&, c&, r&)
    
89.     Dim l1&, r1&, i&, j&
    
90.     l1 = l
    
91.     r1 = c + 1
    
92.     i = l
    
93.     j = l
    
94.     While l1 <= c And r1 <= r '从两端依次取出最大的元素装入临时数组
    
95.         If brr2(l1) >= brr2(r1) Then
    
96.             crr1(i) = brr1(l1)
    
97.             crr2(i) = brr2(l1)
    
98.             i = i + 1
    
99.             l1 = l1 + 1
    
100.         Else
     
101.             crr1(i) = brr1(r1)
     
102.             crr2(i) = brr2(r1)
     
103.             i = i + 1
     
104.             r1 = r1 + 1
     
105.         End If
     
106.     Wend
     
107.     While r1 <= r '先装入右端较大剩余
     
108.         crr1(i) = brr1(r1)
     
109.         crr2(i) = brr2(r1)
     
110.         i = i + 1
     
111.         r1 = r1 + 1
     
112.     Wend
     
113.     While l1 <= c '再装入左端较小剩余
     
114.         crr1(i) = brr1(l1)
     
115.         crr2(i) = brr2(l1)
     
116.         i = i + 1
     
117.         l1 = l1 + 1
     
118.     Wend
     
119.     While j <= r
     
120.         brr1(j) = crr1(j)
     
121.         brr2(j) = crr2(j)
     
122.         j = j + 1
     
123.     Wend
     
124. End Sub

复制代码

有两个特点：
1.排序函数的调用争取“与香川原创的调用格式”接轨，如下：
crr = Multi_Key_Sort(arr, xb, sr)
函数名（待排二维数组，数据记录开始下标，键值所在列和升降序一维数组（下标从1开始，有别于利用Array产生的一维数组））

2.升序归并排序和降序归并排序分开写，虽然代码行数激增，但我想效率快吧。

附件如下：

基于归并排序的二维数据表多key排序_by aoe1981.zip (254.21 KB, 下载次数: 103)

2019-10-6 17:03 上传

点击文件名下载附件

请各路大神指正。

aoe1981

为了数据的保密，搜索到了一个实用的工具，可以快速把汉字转换成拼音首字母组合，代码如下：

1. Function PinYin(p As String) As String
   
2.     Dim i&
   
3.     i = Asc(p)
   
4.     Select Case i
   
5.     Case -20319 To -20284: PinYin = "A"
   
6.     Case -20283 To -19776: PinYin = "B"
   
7.     Case -19775 To -19219: PinYin = "C"
   
8.     Case -19218 To -18711: PinYin = "D"
   
9.     Case -18710 To -18527: PinYin = "E"
   
10.     Case -18526 To -18240: PinYin = "F"
    
11.     Case -18239 To -17923: PinYin = "G"
    
12.     Case -17922 To -17418: PinYin = "H"
    
13.     Case -17417 To -16475: PinYin = "J"
    
14.     Case -16474 To -16213: PinYin = "K"
    
15.     Case -16212 To -15641: PinYin = "L"
    
16.     Case -15640 To -15166: PinYin = "M"
    
17.     Case -15165 To -14923: PinYin = "N"
    
18.     Case -14922 To -14915: PinYin = "O"
    
19.     Case -14914 To -14631: PinYin = "P"
    
20.     Case -14630 To -14150: PinYin = "Q"
    
21.     Case -14149 To -14091: PinYin = "R"
    
22.     Case -14090 To -13319: PinYin = "S"
    
23.     Case -13318 To -12839: PinYin = "T"
    
24.     Case -12838 To -12557: PinYin = "W"
    
25.     Case -12556 To -11848: PinYin = "X"
    
26.     Case -11847 To -11056: PinYin = "Y"
    
27.     Case -11055 To -2050: PinYin = "Z"
    
28.     Case Else: PinYin = p
    
29.     End Select
    
30. End Function
    
31. Function GetPY(str)
    
32.     Dim i&
    
33.     For i = 1 To Len(str)
    
34.         GetPY = GetPY & PinYin(Mid(str, i, 1))
    
35.     Next i
    
36. End Function

复制代码

取之于网，用之于网，不敢独享，也贴出来。

附件中还有一段代码：

1. Option Explicit
   
2. Public Sub XuLie() '序列
   
3.     Dim ar(), l&, i&, s$
   
4.     With Sht1
   
5.         ar = .Range("a1:" & .Cells(1, Columns.Count).End(xlToLeft).Address(0, 0)).Value
   
6.     End With
   
7.     l = UBound(ar, 2)
   
8.     For i = 1 To l
   
9.         s = s & "," & ar(1, i)
   
10.     Next i
    
11.     s = Mid(s, 2)
    
12.     With Sht2
    
13.         .Range("b2:b100").ClearContents
    
14.         With .Range("b2:b" & l + 1).Validation
    
15.             .Delete
    
16.             .Add Type:=xlValidateList, Formula1:=s
    
17.         End With
    
18.         .Names.Add Name:="quyu", RefersToR1C1:="=OFFSET(二维数据表!R1C1,,,1," & l & ")"
    
19.     End With
    
20. End Sub

复制代码

是自动添加“有效性序列”和定义“名称”的，便于直观选择排序key值，特此说明。

aoe1981

又测试了一下效率，我把原有数据记录反复复制粘贴替换，共得到11312条、56560条记录，做了三次测试：


一、11312条记录，5个key，用时2.390625秒，含读取工作表数据和输出到工作表的时间。


二、11312条记录，7个key，用时2.515625秒，含读取工作表数据和输出到工作表的时间。
　　此时可以作一些计算：（2.515625－2.390625）／（7－5）＝0.0625（秒），这与我用归并对10000个一维数据排序的时间基本一致，读取工作表、填充工作表比较费时间。


三、56560条记录，7个key，用时13.17188秒，含读取工作表数据和输出到工作表的时间。
　　前两次，我也对比了工作表排序，其速度像飞一样。这次，我明显感觉到工作表排序也大致经过了5秒时间。相比这下，本帖仍是做了一些无用功。


最让人头疼的是，关于文本比较大小，我似乎没有发现其中的秘密。我用的7个key依次是：
学区、考点、考场、年级（附件中名为“学校”，我改了）、班级、姓名、性别
1、2、1、2、1、1、2
对比工作表排序结果：56560条记录中，1400条记录排序不一致；
我再将工作表排序中最后一个key“性别”改为升序1，重新排序对比：56560条记录中，2280条记录排序不一致。


真让人抓狂！！！不仅“男、女”的大小比较工作表与Vba存在差异，应该其他文本也有差异，这该怎么解决呢？？？

aoe1981

又用香川大侠的附件测试了下，56560条记录，7个key，依次是：
学区、考点、考场、年级（附件中名为“学校”，我改了）、班级、姓名、性别
1、2、1、2、1、1、2

香川大侠用的底层排序是快速排序，且做了稳定性处理，速度略胜于我的归并排序，这是已知的事实，运行时间见下图，同一电脑，同一组数据，同样的时间起止点：


用时10.41秒，比我的13.17188秒，提升了约21％。

重点在于结果：


香川大侠的多key排序结果与我的结果是完全一致的，与工作表排序结果和我遇到的一样，不完全一致，如上图：56560条记录中2280条记录不一致。

这还真是让我找到了知音，哈哈，看来我把这个问题还发现的早，因为我有比较像样的原始数据。

aoe1981

为了尝试解决楼上的问题，研究了一下工作表排序的录制宏：

1. Option Explicit
   
2. Sub 宏1()
   
3.     With ActiveWorkbook.Worksheets("二维数据表").Sort
   
4.         .SortFields.Clear
   
5.         .SortFields.Add Key:=Range("B2:B56561"), Order:=xlAscending, DataOption:=xlSortNormal
   
6.         .SortFields.Add Key:=Range("C2:C56561"), Order:=xlDescending, DataOption:=xlSortNormal
   
7.         .SortFields.Add Key:=Range("D2:D56561"), Order:=xlAscending, DataOption:=xlSortNormal
   
8.         .SortFields.Add Key:=Range("I2:I56561"), Order:=xlDescending, DataOption:=xlSortNormal
   
9.         .SortFields.Add Key:=Range("J2:J56561"), Order:=xlAscending, DataOption:=xlSortNormal
   
10.         .SortFields.Add Key:=Range("G2:G56561"), Order:=xlAscending, DataOption:=xlSortNormal
    
11.         .SortFields.Add Key:=Range("H2:H56561"), Order:=xlDescending, DataOption:=xlSortNormal
    
12.         .SetRange Range("A1:P56561")
    
13.         .Header = xlYes
    
14.         .SortMethod = xlPinYin
    
15.         .Apply
    
16.     End With
    
17. End Sub
    
18. Sub 宏2()
    
19.     With ActiveWorkbook.Worksheets("二维数据表").Sort
    
20.         .SortFields.Clear
    
21.         .SortFields.Add Key:=Range("B2:B56561"), Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    
22.         .SortFields.Add Key:=Range("C2:C56561"), Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    
23.         .SortFields.Add Key:=Range("D2:D56561"), Order:=xlAscending, DataOption:=xlSortNormal
    
24.         .SortFields.Add Key:=Range("I2:I56561"), Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    
25.         .SortFields.Add Key:=Range("J2:J56561"), Order:=xlAscending, DataOption:=xlSortNormal
    
26.         .SortFields.Add Key:=Range("G2:G56561"), Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    
27.         .SortFields.Add Key:=Range("H2:H56561"), Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    
28.         .SetRange Range("A1:P56561")
    
29.         .Header = xlYes
    
30.         .SortMethod = xlPinYin
    
31.         .Apply
    
32.     End With
    
33. End Sub

复制代码

上面的“宏1”是正常录制后精简就可以得到的，“宏2”的参数“xlSortTextAsNumbers”却是录制不到的，是我百度资源发现的，链接如下：
https://blog.csdn.net/iamlaosong/article/details/49490623

相关引用如下：
“
XlSortDataOption 可为以下 XlSortDataOption 常量之一。
xlSortTextAsNumbers 将文本作为数字型数据排序。
xlSortNormal 默认值。分别对数字和文本数据进行排序
”

我怀疑是工作表排序参数设置的问题，不仅试了文本按拼音排序“.SortMethod = xlPinYin”，还试了按笔画排序“.SortMethod = xlStroke”，但是始终没有得到一致的结果，真是奇哉怪也！

我初步尽力了。

aoe1981

楼上链接内容中补充一点关键引用：
“
2007版录制的排序语句和2003版完全不同，新的形式Sort不再是对象Range的方法，而是对象Sheet的属性，此属性下面还有很多子属性，其中SortFields子属性用于设置排序关键字，SetRange设置范围，所有属性设置完成后通过方法Apply完成排序。
”
感谢原帖作者。

ychj526926

大神，这速度，觉了！

aman1516

研究终有成果了，强！更谢谢分享！

zopey

1. Function compare(a, b)
   
2. typea = VarType(a)
   
3. If typea = 10 Then compare = 2: Exit Function '错误值
   
4. 
   
5. '比较数据类型 是否相同
   
6. If VarType(b) = typea Then
   
7.    Select Case typea
   
8.        Case 5 '数字
   
9.            If a = b Then
   
10.               compare = 0
    
11.            ElseIf a < b Then
    
12.               compare = -1
    
13.            Else
    
14.               compare = 1
    
15.            End If
    
16.        Case 11 '逻辑值 true false
    
17.            If a = b Then
    
18.               compare = 0
    
19.            ElseIf a > b Then
    
20.               compare = -1
    
21.            Else
    
22.               compare = 1
    
23.            End If
    
24.        Case 8 '文本比较， vbTextCompare =不区分字母大小写
    
25.            compare = StrComp(a, b, vbTextCompare)
    
26.    End Select
    
27. Else
    
28.    compare = 4
    
29. End If
    
30. End Function

复制代码

要模拟工作表排序，vba比较大小 要按类型 分析

microyip

没有具体比较过具体差异，但我自己之前也写过一个《二维（以下）数组排序的自定义函数》，请你研究对比、指正
http://club.excelhome.net/thread-1443182-1-1.html