怎么用VBA获取excell中的指定规则来排序

jnear

如图，按照 Sheet2里的规则，对Sheet1里的内容进行排序。请高手帮帮忙{:soso_e154:}




附件：
指定规则排序.rar (7.24 KB, 下载次数: 72)

2013-10-28 20:18 上传

点击文件名下载附件

zhaogang1960

按照Sheet2中B列循序排序，如果是请测试：

1. Sub 宏1()
   
2.     Dim arr
   
3.     arr = Sheets("Sheet2").Range("B1:B" & Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row)
   
4.     Application.AddCustomList ListArray:=arr
   
5.     Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Header:=xlYes, _
   
6.                 OrderCustom:=Application.CustomListCount + 1
   
7.     Application.DeleteCustomList ListNum:=Application.CustomListCount
   
8. End Sub

复制代码

zhaogang1960

请看附件
指定规则排序.rar (17.06 KB, 下载次数: 105)

2013-10-28 21:21 上传

点击文件名下载附件

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d As Object, i&, j&, k&, s&, y&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. crr = arr
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. y = UBound(brr)
   
8. For i = 2 To UBound(arr)
   
9.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
   
10. Next
    
11. For i = 1 To UBound(brr)
    
12.     x = Split(Mid(d(brr(i, 2)), 2), ",")
    
13.     s = 0
    
14.     For j = 0 To UBound(x)
    
15.         s = j * y + i + 1
    
16.         For k = 1 To UBound(arr, 2)
    
17.             crr(s, k) = arr(x(j), k)
    
18.         Next
    
19.     Next
    
20. Next
    
21. Range("f1").Resize(UBound(crr), UBound(crr, 2)) = crr
    
22. End Sub
    

复制代码

dsmch

………………

jnear

zhaogang1960 发表于 2013-10-28 21:18
按照Sheet2中B列循序排序，如果是请测试：

受教了。测试了下，在Sheet2.B列里增加内容也可以自动排序，很强大，非常感谢。

jnear

dsmch 发表于 2013-10-28 22:03

看了下效果，最后结果是按学期来排序了，不是我要的效果哦。不过还是非常感觉您的帮忙。

dsmch

jnear 发表于 2013-10-29 08:38
看了下效果，最后结果是按学期来排序了，不是我要的效果哦。不过还是非常感觉您的帮忙。

1. Sub Macro1()
   
2. Dim arr, brr, crr, d As Object, i&, j&, k&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. crr = arr
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. For i = 2 To UBound(arr)
   
8.     d(arr(i, 1)) = d(arr(i, 1)) & "," & i
   
9. Next
   
10. s = 1
    
11. For i = 1 To UBound(brr)
    
12.     x = Split(Mid(d(brr(i, 2)), 2), ",")
    
13.     For j = 0 To UBound(x)
    
14.         s = s + 1
    
15.         For k = 1 To UBound(arr, 2)
    
16.             crr(s, k) = arr(x(j), k)
    
17.         Next
    
18.     Next
    
19. Next
    
20. Range("f1").Resize(UBound(crr), UBound(crr, 2)) = crr
    
21. End Sub
    

复制代码

dsmch

……………………

鄂龙蒙

zhaogang1960 发表于 2013-10-28 21:18
按照Sheet2中B列循序排序，如果是请测试：

请教：按C列数字大小排呢？谢谢！