|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 aoe1981 于 2019-10-6 19:09 编辑
近来很长时间在折腾“一维数据排序”算法学习,见下帖:
排序算法学习
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如此矛盾和纠结呢?
找到原因后,我便放心了,可以发帖了。放心的不是说自己多优秀,而是其正确性。
主程序代码如下:
- Public Sub Main() '主程序
- Dim arr(), crr(), tj(), rng As Range, sh$, xb&, n&, m&, i&, d As Object, di, sr&(), t!
- t = Timer()
- Set rng = Sht1.Range("a1").CurrentRegion
- If rng.Count < 2 Then MsgBox "源数据错误。", , "by aoe1981 2019/10/06": Exit Sub
- arr = rng.Value
- Set rng = Nothing
- n = UBound(arr, 1)
- m = UBound(arr, 2)
- With Sht2
- sh = .Range("a2").Value
- tj = .Range("c2:d" & m + 1).Value
- End With
- If sh = "是" And n = 1 Then MsgBox "源数据只有标题行。", , "by aoe1981 2019/10/06": Exit Sub
- If sh = "是" Then xb = 1 Else xb = 2
- Set d = CreateObject("scripting.dictionary")
- For i = 1 To m
- If tj(i, 1) <> "" Then d(tj(i, 1)) = tj(i, 2) '排序条件去重
- Next i
- Erase tj
- ReDim sr&(1 To d.Count * 2)
- i = 1
- For Each di In d.keys '排序条件转换格式与香川接轨
- sr(2 * i - 1) = di
- sr(2 * i) = d(di)
- i = i + 1
- Next di
- Set d = Nothing
- crr = Multi_Key_Sort(arr, xb, sr) '第二参数不一样,表示排序记录开始的下标
- With Sht3
- .Cells.ClearContents
- .Range("a1").Resize(n, m).Value = crr
- .Cells.EntireColumn.AutoFit
- End With
- MsgBox "用时:" & Timer() - t & "秒", , "by aoe1981 2019/10/06"
- End Sub
复制代码
排序函数代码如下:
- Option Explicit
- Dim brr1(), brr2(), crr1(), crr2()
- Public Function Multi_Key_Sort(arr1(), xb1&, sr1&())
- Dim n&, m&, i&, j&
- n = UBound(arr1, 1)
- m = UBound(arr1, 2)
- ReDim brr1(xb1 To n), brr2(xb1 To n), crr1(xb1 To n), crr2(xb1 To n)
- For j = xb1 To n
- brr1(j) = j '记录序号
- Next j
- For i = UBound(sr1) To 2 Step -2
- For j = xb1 To n
- brr2(j) = arr1(brr1(j), sr1(i - 1)) '排序字段
- Next j
- If sr1(i) = 1 Then
- Call MergeSort1(xb1, n)
- ElseIf sr1(i) = 2 Then
- Call MergeSort2(xb1, n)
- End If
- Next i
- ReDim arr2(1 To n, 1 To m)
- For i = xb1 To n
- For j = 1 To m
- arr2(i, j) = arr1(brr1(i), j)
- Next j
- Next i
- If xb1 > 1 Then '排序数据不含标题行时写入标题行
- For j = 1 To m
- arr2(1, j) = arr1(1, j)
- Next j
- End If
- Multi_Key_Sort = arr2
- Erase brr1, brr2, crr1, crr2
- End Function
- Public Sub MergeSort1(l&, r&) '归并排序(升序)
- If l = r Then Exit Sub
- Dim c&
- c = Int((l + r) / 2)
- Call MergeSort1(l, c)
- Call MergeSort1(c + 1, r)
- If brr2(c) > brr2(c + 1) Then Call DG1(l, c, r)
- End Sub
- Public Sub DG1(l&, c&, r&)
- Dim l1&, r1&, i&, j&
- l1 = l
- r1 = c + 1
- i = l
- j = l
- While l1 <= c And r1 <= r '从两端依次取出最小的元素装入临时数组
- If brr2(l1) <= brr2(r1) Then
- crr1(i) = brr1(l1)
- crr2(i) = brr2(l1)
- i = i + 1
- l1 = l1 + 1
- Else
- crr1(i) = brr1(r1)
- crr2(i) = brr2(r1)
- i = i + 1
- r1 = r1 + 1
- End If
- Wend
- While r1 <= r '先装入右端较小剩余
- crr1(i) = brr1(r1)
- crr2(i) = brr2(r1)
- i = i + 1
- r1 = r1 + 1
- Wend
- While l1 <= c '再装入左端较大剩余
- crr1(i) = brr1(l1)
- crr2(i) = brr2(l1)
- i = i + 1
- l1 = l1 + 1
- Wend
- While j <= r
- brr1(j) = crr1(j)
- brr2(j) = crr2(j)
- j = j + 1
- Wend
- End Sub
- Public Sub MergeSort2(l&, r&) '归并排序(降序)
- If l = r Then Exit Sub
- Dim c&
- c = Int((l + r) / 2)
- Call MergeSort2(l, c)
- Call MergeSort2(c + 1, r)
- If brr2(c) < brr2(c + 1) Then Call DG2(l, c, r)
- End Sub
- Public Sub DG2(l&, c&, r&)
- Dim l1&, r1&, i&, j&
- l1 = l
- r1 = c + 1
- i = l
- j = l
- While l1 <= c And r1 <= r '从两端依次取出最大的元素装入临时数组
- If brr2(l1) >= brr2(r1) Then
- crr1(i) = brr1(l1)
- crr2(i) = brr2(l1)
- i = i + 1
- l1 = l1 + 1
- Else
- crr1(i) = brr1(r1)
- crr2(i) = brr2(r1)
- i = i + 1
- r1 = r1 + 1
- End If
- Wend
- While r1 <= r '先装入右端较大剩余
- crr1(i) = brr1(r1)
- crr2(i) = brr2(r1)
- i = i + 1
- r1 = r1 + 1
- Wend
- While l1 <= c '再装入左端较小剩余
- crr1(i) = brr1(l1)
- crr2(i) = brr2(l1)
- i = i + 1
- l1 = l1 + 1
- Wend
- While j <= r
- brr1(j) = crr1(j)
- brr2(j) = crr2(j)
- j = j + 1
- Wend
- End Sub
复制代码
有两个特点:
1.排序函数的调用争取“与香川原创的调用格式”接轨,如下:
crr = Multi_Key_Sort(arr, xb, sr)
函数名(待排二维数组,数据记录开始下标,键值所在列和升降序一维数组(下标从1开始,有别于利用Array产生的一维数组))
2.升序归并排序和降序归并排序分开写,虽然代码行数激增,但我想效率快吧。
附件如下:
基于归并排序的二维数据表多key排序_by aoe1981.zip
(254.21 KB, 下载次数: 105)
请各路大神指正。
|
评分
-
4
查看全部评分
-
|