怎么用二位数组实现这个分组排序

陈酿

附件是针对于后三列排序（sheet1 排序前，sheet2排序后），现在需要根据数据的倒数n列，n可能是4以上的数值，怎么用二维数组来实现呢

问题.rar (1.64 KB, 下载次数: 55)

2011-9-20 12:49 上传

点击文件名下载附件

陈酿

自己顶一下

jiangxj

加辅助列:j1=i1 & h1 & g1 & f1 下拉
按j 列排序

陈酿

jiangxj 发表于 2011-9-20 13:04
加辅助列:j1=i1 & h1 & g1 & f1 下拉
按j 列排序

要求不让用辅助列

香川群子

其实也不太难。

Excel排序的原则是，最重要的排序要放在最后一个操作。

如果你要按照倒数第1列、倒数第2列、倒数第3列、……倒数第n列的顺序来对数据排序的话，
实际操作时需要反过来，即：
先排倒数第n列，然后倒数n-1列……倒数第3列、倒数第2列、倒数第1列。结束。


代码如下：

1. Sub px1()
   
2.     m = [a1].End(2).Column '获取排序范围总列数m
   
3.     n = InputBox("Please input sort columns number:" & vbCr & "less then  <= " & m, "sort", 4)
   
4.     If n = "" Then Exit Sub Else n = Val(n) ‘对话窗输入要从倒数第n列开始排序。取消则退出宏。
   
5.     If n=0 or n > m Then '如果输入列数n=0，或n大于实际列数m，则恢复默认第1列排序后退出宏。
   
6.         MsgBox "Will be Restore (Sort by No.1)" '出现提示对话框
   
7.         [a1].CurrentRegion.Sort Key1:=[a1], Header:=xlYes '恢复按第1列排序。
   
8.         Exit Sub '退出宏
   
9.     End If
   
10.     For i = 1 To n '按倒数第n列开始排序直至倒数第1列。
    
11.         [a1].CurrentRegion.Sort Key1:=[a1].Offset(0, m - n + i - 1), Header:=xlYes
    
12.     Next
    
13. End Sub
    

复制代码

香川群子

但是，如果要在内存二维数组内实现排序操作，会很麻烦的。

VBA代码排序，速度远没有Excel表内的Sort操作快。（这是我当初的想法，后来证明不一定。）

…………
呵呵，经过思考，完成了数组内排序的代码：

1. Sub szpx(x(), m, n, k, h)
   
2. For i = LBound(x) + h To UBound(x)
   
3. ts = x(i, n)
   
4. ps = "," & i
   
5. 
   
6. For j = i + 1 To UBound(x)
   
7. If ts > x(j, n) Then
   
8. ts = x(j, n)
   
9. ps = "," & j
   
10. ElseIf ts = x(j, n) Then
    
11. ps = ps & "," & j
    
12. End If
    
13. Next
    
14. 
    
15. t = Split(ps, ",")
    
16. c = UBound(t)
    
17. 
    
18. y = x
    
19. For j = 1 To c
    
20. For l = 1 To m
    
21. y(i + j - 1, l) = x(t(j), l)
    
22. Next
    
23. x(t(j), n) = ""
    
24. Next
    
25. 
    
26. k = i + c
    
27. For j = i To UBound(x)
    
28. If x(j, n) = "" Then
    
29. If c = 1 Then Exit For Else c = c - 1
    
30. Else
    
31. For l = 1 To m
    
32. y(k, l) = x(j, l)
    
33. Next
    
34. k = k + 1
    
35. End If
    
36. Next
    
37. 
    
38. x = y
    
39. 
    
40. Next
    
41. End Sub
    

复制代码

下面是执行代码：
和Excel排序代码几乎相同，不解释了。

1. Sub px2()
   
2.     m = [a1].End(2).Column
   
3.     n = InputBox("Please input sort columns number:" & vbCr & "less then  <= " & m, "sort", 4)
   
4.     If n = "" Then Exit Sub Else n = Val(n)
   
5.     tm = Timer
   
6.    
   
7.     ReDim arr(1, 1)
   
8.     x = [a1].CurrentRegion
   
9.     arr = x
   
10.    
    
11.     If n = 0 Or n > m Then
    
12.         MsgBox "Will be Restore (Sort by No.1)"
    
13.         tm = Timer
    
14. '        [a1].CurrentRegion.Sort Key1:=[a1], Header:=xlYes
    
15.         szpx arr, m, 1, 0, 1
    
16.         [a1].CurrentRegion = arr
    
17.         MsgBox Format(Timer - tm, "0.000")
    
18.         Exit Sub
    
19.     End If
    
20.    
    
21.     For i = 1 To n
    
22.         szpx arr, m, m - n + i, 0, 1
    
23. '        [a1].CurrentRegion = arr
    
24.     Next
    
25.     [a1].CurrentRegion = arr
    
26.    
    
27.     MsgBox Format(Timer - tm, "0.000")
    
28. End Sub
    

复制代码

试验结果，居然数组比Excel排序更快一些。不可思议。

最后是附件：

Sort2.zip (12 KB, 下载次数: 163)

2011-9-20 16:51 上传

点击文件名下载附件

香川群子

增加了Z-A排序的内容。

以及，数组内排序，增加了空白单元格自动排最后。

首先，是Excel自带排序功能的录制代码：

1. Sub px1()
   
2.     m = [a1].End(2).Column
   
3.     n = InputBox("Please input sort columns number:" & vbCr & "less then  <= " & m, "sort", 0)
   
4.     If n = "" Then Exit Sub Else n = Val(n)
   
5.     s = InputBox("Please select s=0 for Ascending or s=1 for Descending Order", "sort", 0)
   
6.     tm = Timer
   
7.    
   
8.     If n = 0 Or n > m Then
   
9.         MsgBox "Will be Restore (Sort by No.1)"
   
10.         tm = Timer
    
11.         If s = 0 Then
    
12.             [a1].CurrentRegion.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
    
13.         ElseIf s = 1 Then
    
14.             [a1].CurrentRegion.Sort Key1:=[a1], Order1:=xlDescending, Header:=xlYes
    
15.         End If
    
16.         MsgBox Format(Timer - tm, "0.000")
    
17.         Exit Sub
    
18.     End If
    
19.     If s = 0 Then
    
20.         For i = 1 To n
    
21.             [a1].CurrentRegion.Sort Key1:=[a1].Offset(0, m - n + i - 1), Order1:=xlAscending, Header:=xlYes
    
22.         Next
    
23.     ElseIf s = 1 Then
    
24.         For i = 1 To n
    
25.             [a1].CurrentRegion.Sort Key1:=[a1].Offset(0, m - n + i - 1), Order1:=xlDescending, Header:=xlYes
    
26.         Next
    
27.     End If
    
28.    
    
29.     MsgBox Format(Timer - tm, "0.000")
    
30. End Sub

复制代码

下面是数组操作代码：

1. Sub px2()
   
2.     m = [a1].End(2).Column
   
3.     n = InputBox("Please input sort columns number:" & vbCr & "less then  <= " & m, "sort", 0)
   
4.     If n = "" Then Exit Sub Else n = Val(n)
   
5.     s = InputBox("Please select s=0 for Ascending or s=1 for Descending Order", "sort", 0)
   
6.     tm = Timer
   
7.    
   
8.     ReDim arr(1, 1)
   
9.     x = [a1].CurrentRegion
   
10.     arr = x
    
11.    
    
12.     If n = 0 Or n > m Then
    
13.         MsgBox "Will be Restore (Sort by No.1)"
    
14.         tm = Timer
    
15. '        [a1].CurrentRegion.Sort Key1:=[a1], Header:=xlYes
    
16.         szpx arr, m, 1, s, 1
    
17.         [a1].CurrentRegion = arr
    
18.         MsgBox Format(Timer - tm, "0.000")
    
19.         Exit Sub
    
20.     End If
    
21.    
    
22.     For i = 1 To n
    
23.         szpx arr, m, m - n + i, s, 1
    
24. '        [a1].CurrentRegion = arr
    
25.     Next
    
26.     [a1].CurrentRegion = arr
    
27.    
    
28.     MsgBox Format(Timer - tm, "0.000")
    
29. End Sub

复制代码

最后，是数组内排序的过程代码：

1. Sub szpx(x(), m, n, s, h)
   
2.     For i = LBound(x) + h To UBound(x)
   
3.         If x(i, n) = "" Then p = p & "," & i
   
4.     Next
   
5.     If p <> "" Then
   
6.         y = x
   
7.         k = h
   
8.         For j = LBound(x) + h To UBound(x)
   
9.             If x(j, n) <> "" Then
   
10.                 k = k + 1
    
11.                 For l = 1 To m
    
12.                     y(k, l) = x(j, l)
    
13.                 Next
    
14.             End If
    
15.         Next
    
16.         
    
17.         q = Split(p, ",")
    
18.         b = UBound(q)
    
19.         For j = 1 To b
    
20.             k = k + 1
    
21.             For l = 1 To m
    
22.                 y(k, l) = x(q(j), l)
    
23.             Next
    
24.         Next
    
25.         x = y
    
26.     End If
    
27.    
    
28.     For i = LBound(x) + h To UBound(x) - b
    
29.         t = x(i, n)
    
30.         p = "," & i
    
31.         For j = i + 1 To UBound(x) - b
    
32.             If s = 0 And t > x(j, n) Then
    
33.                 t = x(j, n)
    
34.                 p = "," & j
    
35.             ElseIf s = 1 And t < x(j, n) Then
    
36.                 t = x(j, n)
    
37.                 p = "," & j
    
38.             ElseIf t = x(j, n) Then
    
39.                 p = p & "," & j
    
40.             End If
    
41.         Next
    
42.         
    
43.         q = Split(p, ",")
    
44.         c = UBound(q)
    
45.         
    
46.         y = x
    
47.         For j = 1 To c
    
48.             For l = 1 To m
    
49.                 y(i + j - 1, l) = x(q(j), l)
    
50.             Next
    
51.             x(q(j), n) = ""
    
52.         Next
    
53.         
    
54.         k = i + c
    
55.         For j = i To UBound(x) - b
    
56.             If x(j, n) = "" Then
    
57.                 If c = 1 Then Exit For Else c = c - 1
    
58.             Else
    
59.                 For l = 1 To m
    
60.                     y(k, l) = x(j, l)
    
61.                 Next
    
62.                 k = k + 1
    
63.             End If
    
64.         Next
    
65.         
    
66.         x = y
    
67.         
    
68.     Next
    
69. End Sub
    
70. 
    

复制代码

最后，发现数组内排序操作，当数据量稍多就很慢了。

eujgnaw

为啥不用sql来排序。很省力

1. Sub Macro1()
   
2.     Dim cnn As Object, SQL$
   
3.     Set cnn = CreateObject("ADODB.Connection")
   
4.     cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties =Excel 8.0;Data Source =" & ThisWorkbook.FullName
   
5.     SQL = "Select * from [Sheet1$" & Sheet1.[a1].CurrentRegion.Address(0, 0) & "] order by h,g,f,e,d,c,b,a"
   
6.     With Sheet2
   
7.         .UsedRange.Offset(1).ClearContents
   
8.         .[a2].CopyFromRecordset cnn.Execute(SQL)
   
9.     End With
   
10.     cnn.Close
    
11.     Set cnn = Nothing
    
12. End Sub

复制代码

香川群子

sql 方法不错，也很快。但是和Excel自带排序不同，空格会排在最前面。

陈酿

eujgnaw 发表于 2011-9-22 16:41
为啥不用sql来排序。很省力

不让用啊 sql的话很多都方便了