二维数组排序，可与range.sort媲美

VBA万岁

VBA万岁 发表于 2014-4-18 16:43
截图如下：
排序前：

附件如下：
多列列表框筛选排序.rar (24.35 KB, 下载次数: 232)

2014-4-18 16:44 上传

点击文件名下载附件

VBA万岁

VBA万岁 发表于 2014-4-18 16:43
截图如下：
排序前：

排序前截图：

EXCEL江湖

Zamyi大侠厉害，数组排序代码非常好用，学习了！

aman1516

收藏，看高手论序

wangfeng0918

附件最后一个下不来啊？

wangfeng0918

老账号掉了，申请小号的感觉真不爽啊。要回贴升级哟

wangfeng0918

继续顶，因为我就需要这个代码看一看，排序方法的源代码

wangfeng0918

升级准备看一下源码，可惜作者没有放出来啊？

Zamyi

wangfeng0918 发表于 2015-4-10 21:21
升级准备看一下源码，可惜作者没有放出来啊？

附件包里面有，直接贴个源码吧。不过里面的快排不好。

1. Public Sub ZSort(Olda(), Newa(), ParamArray c())
   
2. 'Olda()：为排序数组
   
3. 'Newa()：为存放结果数组
   
4. 'ParamArray c():传递排序参数数组,奇数个为排序列号，偶数为升降序，0或者省略为升序
   
5. Dim P() As Long, w() As Long, B() As Boolean
   
6. Dim i&, j&, k&, n1&, n2&, nb&, ne&
   
7. k = UBound(c)
   
8. If k = -1 Then
   
9.   ReDim P(1)
   
10.   P(0) = 1
    
11. Else
    
12.   If k Mod 2 Then ReDim P(k) Else ReDim P(k + 1)
    
13.   For i = 0 To k
    
14.     P(i) = c(i)
    
15.   Next
    
16. End If
    
17. 
    
18. n1 = LBound(Olda)
    
19. n2 = UBound(Olda)
    
20. ReDim w(n1 To n2)
    
21. ReDim B(n1 To n2)
    
22. For i = n1 To n2
    
23.   w(i) = i
    
24. Next
    
25. 
    
26. If P(1) = 0 Then QSort Olda, w, P(0), n1, n2 Else QSort2 Olda, w, P(0), n1, n2
    
27. For i = 2 To k Step 2
    
28.   nb = n1
    
29.   ne = n1
    
30.   While ne < n2
    
31.     Do
    
32.       ne = ne + 1
    
33.       If ne > n2 Then Exit Do
    
34.     Loop Until B(ne) Or Olda(w(ne), P(i - 2)) <> Olda(w(ne - 1), P(i - 2))
    
35.     If ne - nb > 1 Then
    
36.       If P(i + 1) = 0 Then QSort Olda, w, P(i), nb, ne - 1 Else QSort2 Olda, w, P(i), nb, ne - 1
    
37.     End If
    
38.     If ne <= n2 Then B(ne) = True
    
39.     nb = ne
    
40.   Wend
    
41. Next
    
42. 
    
43. For i = n1 To n2
    
44.   For j = 1 To UBound(Newa, 2)
    
45.     Newa(i, j) = Olda(w(i), j)
    
46.   Next
    
47. Next
    
48. End Sub
    
49. 
    
50. Private Sub QSort(R(), w() As Long, Key&, L&, H&)
    
51. Dim i&, j&, x, y
    
52. i = L
    
53. j = H
    
54. x = R(w(L + 1 + Int((H - L - 1) * Rnd)), Key)
    
55. While (i <= j)
    
56.   While (R(w(i), Key) < x And i < H)
    
57.     i = i + 1
    
58.   Wend
    
59.   While (x < R(w(j), Key) And j > L)
    
60.     j = j - 1
    
61.   Wend
    
62.   If (i <= j) Then
    
63.     y = w(i)
    
64.     w(i) = w(j)
    
65.     w(j) = y
    
66.     i = i + 1
    
67.     j = j - 1
    
68.   End If
    
69. Wend
    
70. If (L < j) Then QSort R, w, Key, L, j
    
71. If (i < H) Then QSort R, w, Key, i, H
    
72. End Sub
    
73. Private Sub QSort2(R(), w() As Long, Key&, L&, H&)
    
74. Dim i&, j&, x, y
    
75. i = L
    
76. j = H
    
77. x = R(w(L + 1 + Int((H - L - 1) * Rnd)), Key)
    
78. While (i <= j)
    
79.   While (R(w(i), Key) > x And i < H)
    
80.     i = i + 1
    
81.   Wend
    
82.   While (x > R(w(j), Key) And j > L)
    
83.     j = j - 1
    
84.   Wend
    
85.   If (i <= j) Then
    
86.     y = w(i)
    
87.     w(i) = w(j)
    
88.     w(j) = y
    
89.     i = i + 1
    
90.     j = j - 1
    
91.   End If
    
92. Wend
    
93. If (L < j) Then QSort2 R, w, Key, L, j
    
94. If (i < H) Then QSort2 R, w, Key, i, H
    
95. End Sub

复制代码

jpj123

好东东，值得收藏，感谢分享。