[已解决]按照如此次序排序

mmc998

工作簿和1.rar (12.77 KB, 下载次数: 15)

2015-3-23 07:25 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-3-23 10:17

化简为烦。。。。。。。。

1. Sub tt()
   
2.     r = [e65536].End(3).Row
   
3.     arr = Range("a5:e" & r)
   
4.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5.     xrr = [h1:al1]     '排序依据
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For k = 1 To UBound(xrr, 2)
   
8.         x = xrr(1, k)
   
9.         For i = 1 To UBound(arr)       '在排序依据中，以此排序
   
10.             If arr(i, 5) = x Then
    
11.                 If Not d.exists(i) Then
    
12.                     n = n + 1
    
13.                     d(i) = ""
    
14.                     For j = 1 To UBound(arr, 2)
    
15.                         brr(n, j) = arr(i, j)
    
16.                     Next
    
17.                 End If
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     If n < UBound(arr) Then          '在排序依据外，按原序放在最后
    
22.         For i = 1 To UBound(arr)
    
23.             If Not d.exists(i) Then
    
24.                 n = n + 1
    
25.                 For j = 1 To UBound(arr, 2)
    
26.                     brr(n, j) = arr(i, j)
    
27.                 Next
    
28.             End If
    
29.         Next
    
30.     End If
    
31.     [g5].Resize(n, UBound(brr, 2)) = brr
    
32. End Sub
    

复制代码

跳转到最佳答案楼层

baksy

没看懂什么意思~

mmc998

baksy 发表于 2015-3-23 08:33
没看懂什么意思~

和值按13,15,14,11,16,12,17,10,18,9,8,19等排序

雪舞子

1. Sub test()
   
2.     Dim ar, x%, rng As Range
   
3.     For x = 1 To 3 Step 2
   
4.         Set rng = Range(Cells(5, x), Cells(224, x))
   
5.         ActiveSheet.Sort.SortFields.Clear
   
6.         ActiveSheet.Sort.SortFields.Add Key:=rng, _
   
7.             SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Join([h1:ai1&""], ","), DataOption:=xlSortNormal
   
8.         With ActiveSheet.Sort
   
9.             .SetRange rng
   
10.             .Header = xlNo
    
11.             .MatchCase = False
    
12.             .Orientation = xlTopToBottom
    
13.             .SortMethod = xlPinYin
    
14.             .Apply
    
15.         End With
    
16.     Next
    
17. End Sub

复制代码

工作簿和1.rar (22.04 KB, 下载次数: 7)

2015-3-23 09:37 上传

点击文件名下载附件

baksy

mmc998 发表于 2015-3-23 08:41
和值按13,15,14,11,16,12,17,10,18,9,8,19等排序

为什么是13,15,14...的顺序？

grf1973

化简为烦。。。。。。。。

1. Sub tt()
   
2.     r = [e65536].End(3).Row
   
3.     arr = Range("a5:e" & r)
   
4.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5.     xrr = [h1:al1]     '排序依据
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For k = 1 To UBound(xrr, 2)
   
8.         x = xrr(1, k)
   
9.         For i = 1 To UBound(arr)       '在排序依据中，以此排序
   
10.             If arr(i, 5) = x Then
    
11.                 If Not d.exists(i) Then
    
12.                     n = n + 1
    
13.                     d(i) = ""
    
14.                     For j = 1 To UBound(arr, 2)
    
15.                         brr(n, j) = arr(i, j)
    
16.                     Next
    
17.                 End If
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     If n < UBound(arr) Then          '在排序依据外，按原序放在最后
    
22.         For i = 1 To UBound(arr)
    
23.             If Not d.exists(i) Then
    
24.                 n = n + 1
    
25.                 For j = 1 To UBound(arr, 2)
    
26.                     brr(n, j) = arr(i, j)
    
27.                 Next
    
28.             End If
    
29.         Next
    
30.     End If
    
31.     [g5].Resize(n, UBound(brr, 2)) = brr
    
32. End Sub
    

复制代码

grf1973

化烦为简。。。。。。。。。。。。

1. Sub test()
   
2.     Application.AddCustomList ListArray:=[h1:ai1&""]
   
3.     r = [e65536].End(3).Row
   
4.     Range("a5:e" & r).Sort key1:=[e5], OrderCustom:=Application.CustomListCount + 1
   
5.     Application.DeleteCustomList Application.CustomListCount
   
6. End Sub
   

复制代码