请教按定好的次序排序代码怎么写

鄂龙蒙

请教:表中"省别"想按照<顺序>表中的次序排序,代码怎么写?谢谢!

按指定的次序排序.rar (13.28 KB, 下载次数: 15)

2015-5-10 21:29 上传

点击文件名下载附件

yjh_27

自定义序列排序

chxw68

1. Sub test11()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   mybook = ThisWorkbook.FullName
   
7.   With cnn
   
8.     If Application.Version = "11.0" Then
   
9.       .Provider = "microsoft.jet.oledb.4.0"
   
10.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
11.     Else
    
12.       .Provider = "microsoft.ACE.oledb.12.0"
    
13.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;"";data source=" & mybook
    
14.     End If
    
15.     .Open
    
16.   End With
    
17.   sql = "select a.* from [年度汇总$b3:i] a left outer join [顺序$b2:c] b on a.省别=b.省份 order by b.序号"
    
18.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
19.   With Worksheets("sheet1")
    
20.     .Cells.Delete
    
21.     For j = 0 To rs.Fields.Count - 1
    
22.       .Cells(1, j + 1) = rs.Fields(j).Name
    
23.     Next
    
24.     .Range("a2").CopyFromRecordset rs
    
25.   End With
    
26. End Sub
    

复制代码

chxw68

用ADO也能排序。

doitbest

j4 =MATCH(C4,顺序!C:C,0)
再按J列排序。用自定义序列排序也可

chxw68

用字典+辅助列的办法。

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("顺序")
   
7.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.     arr = .Range("b3:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       d(arr(i, 2)) = arr(i, 1)
    
11.     Next
    
12.   End With
    
13.   With Worksheets("年度汇总")
    
14.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
15.     arr = .Range("c4:c" & r)
    
16.     ReDim brr(1 To UBound(arr), 1 To 1)
    
17.     For i = 1 To UBound(arr)
    
18.       If d.exists(arr(i, 1)) Then
    
19.         brr(i, 1) = d(arr(i, 1))
    
20.       End If
    
21.     Next
    
22.     .Range("j4").Resize(UBound(brr), 1) = brr
    
23.     .Range("b3:j" & r).Sort key1:=.Range("j4"), order1:=xlAscending, header:=xlYes
    
24.     .Range("j4:j" & r).ClearContents
    
25.   End With
    
26. End Sub
    

复制代码

chxw68

字典和ADO两种方法。

鄂龙蒙

chxw68 发表于 2015-5-10 21:55
字典和ADO两种方法。

谢谢您的帮助!
再请教:在输出前,数组的首列就是"省别"直接在数组里排序的代码怎么写?

chxw68

鄂龙蒙 发表于 2015-5-10 22:25
谢谢您的帮助!
再请教:在输出前,数组的首列就是"省别"直接在数组里排序的代码怎么写?

将数组写入工作表中，然后用上面的代码排序。

chxw68

不利用辅助列对数组进行排序。

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim d1 As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   With Worksheets("顺序")
   
9.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
10.     arr = .Range("b3:c" & r)
    
11.     For i = 1 To UBound(arr)
    
12.       d(arr(i, 2)) = arr(i, 1)
    
13.     Next
    
14.   End With
    
15.   With Worksheets("年度汇总")
    
16.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
17.     arr = .Range("b4:i" & r)
    
18.     For i = 1 To UBound(arr)
    
19.       d1(arr(i, 2)) = d1(arr(i, 2)) & "+" & i
    
20.     Next
    
21.   End With
    
22.   ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
23.   m = 0
    
24.   For Each aa In d.keys
    
25.     If d1.exists(aa) Then
    
26.       crr = Split(Mid(d1(aa), 2), "+")
    
27.       For i = 0 To UBound(crr)
    
28.         m = m + 1
    
29.         brr(m, 1) = m
    
30.         For j = 2 To UBound(arr, 2)
    
31.           brr(m, j) = arr(Val(crr(i)), j)
    
32.         Next
    
33.       Next
    
34.     End If
    
35.   Next
    
36.   With Worksheets("sheet1")
    
37.     .UsedRange.Offset(1, 0).Clear
    
38.     .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
39.   End With
    
40. End Sub
    

复制代码