[已解决]双条件排序

张雄友

双条件排序，将排序条件放入 array 中，而不是引用单元格：
排序条件黄色单元格（车间，组别）2G,C是排在最后的。     

最佳答案

月排行榜 / 总排行榜

dsmch

2015-5-22 19:33

不用array也可以

1. Sub 自定义纵向排序()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, i&, j&, n&, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. [M3:O65536].ClearContents
   
6. arr = Range("B3:D" & Cells(Rows.Count, 2).End(xlUp).Row) '确定数组范围
   
7. '按排序条件顺序加入字典
   
8. d("3A,A") = 1
   
9. d("3A,B") = 2
   
10. d("3A,C") = 3
    
11. d("3B,A") = 4
    
12. d("3B,B") = 5
    
13. d("3B,C") = 6
    
14. ReDim brr(1 To d.Count, 1 To UBound(arr, 2))
    
15. For i = 1 To UBound(arr)
    
16.     zf = arr(i, 1) & "," & arr(i, 2)
    
17.     s = d(zf)
    
18.     For j = 1 To UBound(arr, 2)
    
19.         brr(s, j) = arr(i, j)
    
20.     Next
    
21. Next
    
22. Range("M3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
23. End Sub

复制代码

跳转到最佳答案楼层

dsmch

第二个排序条件不知，如何知道2G,C是排在最后的？

1. Sub 自定义纵向排序()
   
2. Dim arr, brr, crr, d, i&, j%, k%, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("B3:D" & Cells(Rows.Count, 2).End(xlUp).Row) '确定数组范围
   
5. brr = Array("3A", "3B", "3C", "3D", "3E", "3F", "2G", "2H", "2J", "3G", "3H", "3J") '指定条件，但不知指定第二个条件“组别”？？？？
   
6. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7. For i = 1 To UBound(arr)
   
8.     If Not d.exists(arr(i, 1)) Then
   
9.         d(arr(i, 1)) = i
   
10.     Else
    
11.         d(arr(i, 1)) = d(arr(i, 1)) & "," & i
    
12.     End If
    
13. Next
    
14. For i = 0 To UBound(brr)
    
15.     w = Split(d(brr(i)), ",")
    
16.     For j = 0 To UBound(w)
    
17.         n = n + 1
    
18.         For k = 1 To UBound(arr, 2)
    
19.             crr(n, k) = arr(w(j), k)
    
20.         Next
    
21.     Next
    
22. Next
    
23. Range("M3").Resize(n, UBound(crr, 2)) = crr
    
24. End Sub

复制代码

张雄友

dsmch 发表于 2015-5-21 08:19
第二个排序条件不知，如何知道2G,C是排在最后的？

第二个排序条件不知，如何知道2G,C是排在最后的？

回复：就是将T2：U38 的条件放入 array 中去排序的。

dsmch

1. Sub 自定义纵向排序()
   
2. Dim arr, brr, crr, d, i&, j%, n&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("B3:D" & Cells(Rows.Count, 2).End(xlUp).Row) '确定数组范围
   
5. brr = [t3:u38] 'brr=[{"3A","A";"3A","B";"3A","C"……}]
   
6. ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2))
   
7. For i = 1 To UBound(arr)
   
8.     zf = arr(i, 1) & "," & arr(i, 2)
   
9.     d(zf) = i
   
10. Next
    
11. For i = 1 To UBound(brr)
    
12.     zf = brr(i, 1) & "," & brr(i, 2)
    
13.     If d.exists(zf) Then n = d(zf): s = s + 1
    
14.     For j = 1 To UBound(arr, 2)
    
15.         crr(s, j) = arr(n, j)
    
16.     Next
    
17. Next
    
18. Range("M3").Resize(s, UBound(crr, 2)) = crr
    
19. End Sub

复制代码

张雄友

dsmch 发表于 2015-5-22 06:47

brr = [{"3A","A";"3A","B";"3A","C";"3B","A";"3B","B";"3B","C";"3C","A";"3C","B";"3C","C";"3D","A";"3D","B";"3D","C";"3E","A";"3E","B";"3E","C";"3F","A";"3F","B";"3F","C";"2G","A";"2G","B";"2H","A";"2H","B";"2H","C";"2J","A";"2J","B";"2J","C";"3G","A";"3G","B";"3G","C";"3H","A";"3H","B";"3H","C";"3J","A";"3J","B";"3J","C";"2G","C"}]
标识符太长。不通用过！

张雄友

长度可能是大于250了。

grf1973

加辅助列V列=T列&U列，待排序数据为M:O列，加辅助列P列=M列&O列

1. Sub test()         '按v列所列次序排序
   
2.     Application.AddCustomList ListArray:=[v3:v38&""]
   
3.     r = [e65536].End(3).Row
   
4.     Range("m3:P38").Sort key1:=[p3], OrderCustom:=Application.CustomListCount + 1
   
5.     Application.DeleteCustomList Application.CustomListCount
   
6. End Sub
   

复制代码

张雄友

grf1973 发表于 2015-5-22 14:11
加辅助列V列=T列&U列，待排序数据为M:O列，加辅助列P列=M列&O列

条件在工作表中是不存在的，放在工作表中是为了说明。5 楼放入 array 中太长了，不行。

张雄友

dsmch 发表于 2015-5-22 06:47

红色代码。

dsmch

不用array也可以

1. Sub 自定义纵向排序()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, i&, j&, n&, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. [M3:O65536].ClearContents
   
6. arr = Range("B3:D" & Cells(Rows.Count, 2).End(xlUp).Row) '确定数组范围
   
7. '按排序条件顺序加入字典
   
8. d("3A,A") = 1
   
9. d("3A,B") = 2
   
10. d("3A,C") = 3
    
11. d("3B,A") = 4
    
12. d("3B,B") = 5
    
13. d("3B,C") = 6
    
14. ReDim brr(1 To d.Count, 1 To UBound(arr, 2))
    
15. For i = 1 To UBound(arr)
    
16.     zf = arr(i, 1) & "," & arr(i, 2)
    
17.     s = d(zf)
    
18.     For j = 1 To UBound(arr, 2)
    
19.         brr(s, j) = arr(i, j)
    
20.     Next
    
21. Next
    
22. Range("M3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
23. End Sub

复制代码