[已解决]关于修改排序代码

yvll

这是一段关于数字排序的代码，但是排序后的结果放在了一个单元格，请修改成将排序后的数字按多少分别放在不同的单元格中，谢谢！
排序.rar (10.3 KB, 下载次数: 8)

2014-2-23 22:05 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-2-23 22:16

1. Sub aa()
   
2.     Dim arr2
   
3.     Application.ScreenUpdating = False
   
4.     Dim d As Object
   
5.     Dim d1 As Object
   
6.     For m = 8 To Range("r65536").End(xlUp).Row
   
7.         x = Cells(m, 18)
   
8.         Set d1 = CreateObject("scripting.dictionary")
   
9.         For i = 1 To Len(x)
   
10.             b = Mid(x, i, 1)
    
11.             If Not d1.exists(b) Then d1.Add b, 1 Else d1(b) = d1(b) + 1
    
12.         Next i
    
13.         p1 = ""
    
14.         For i = 0 To 9
    
15.             If InStr(x, i) = 0 Then p1 = p1 & i
    
16.         Next i
    
17.         a = d1.keys: b = d1.items
    
18.         Range("ae1").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(a)
    
19.         Range("af1").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(b)
    
20.         Range("AE1:AF" & d1.Count).Sort Key1:=Range("AF1"), Order1:=xlDescending, Key2:=Range("AE1"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1
    
21.         p = Range("ae1")
    
22.         For i = 2 To d1.Count
    
23.             If Cells(i, "af") = Cells(i - 1, "af") Then p = p & Cells(i, 31) Else p = p & " " & Cells(i, 31)
    
24.         Next i
    
25.         Range("AE1:AF" & d1.Count).ClearContents
    
26.         If p1 <> "" Then
    
27.             arr2 = Split(p & " " & p1, " ")
    
28.             Cells(m, 20) = p & " " & p1
    
29.             '            Cells(m, 21).Resize(, UBound(arr2) + 1).Value = arr2
    
30.             '            Cells(m, 20) = p & " " & p1
    
31.         Else
    
32.             Cells(m, 20) = p    '--------------
    
33.             arr2 = Split(p, " ")
    
34.             '            Cells(m, 21).Resize(, UBound(arr2) + 1).Value = arr2
    
35.             '            Cells(m, 20) = p & " " & p1
    
36.         End If
    
37.         Cells(m, 21).Resize(, UBound(arr2) + 1).Value = arr2
    
38.         Cells(m, 20) = p & " " & p1
    
39.     Next m
    
40.     Set d1 = Nothing
    
41.     Application.ScreenUpdating = True
    
42. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub aa()
   
2.     Dim arr2
   
3.     Application.ScreenUpdating = False
   
4.     Dim d As Object
   
5.     Dim d1 As Object
   
6.     For m = 8 To Range("r65536").End(xlUp).Row
   
7.         x = Cells(m, 18)
   
8.         Set d1 = CreateObject("scripting.dictionary")
   
9.         For i = 1 To Len(x)
   
10.             b = Mid(x, i, 1)
    
11.             If Not d1.exists(b) Then d1.Add b, 1 Else d1(b) = d1(b) + 1
    
12.         Next i
    
13.         p1 = ""
    
14.         For i = 0 To 9
    
15.             If InStr(x, i) = 0 Then p1 = p1 & i
    
16.         Next i
    
17.         a = d1.keys: b = d1.items
    
18.         Range("ae1").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(a)
    
19.         Range("af1").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(b)
    
20.         Range("AE1:AF" & d1.Count).Sort Key1:=Range("AF1"), Order1:=xlDescending, Key2:=Range("AE1"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1
    
21.         p = Range("ae1")
    
22.         For i = 2 To d1.Count
    
23.             If Cells(i, "af") = Cells(i - 1, "af") Then p = p & Cells(i, 31) Else p = p & " " & Cells(i, 31)
    
24.         Next i
    
25.         Range("AE1:AF" & d1.Count).ClearContents
    
26.         If p1 <> "" Then
    
27.             arr2 = Split(p & " " & p1, " ")
    
28.             Cells(m, 20) = p & " " & p1
    
29.             '            Cells(m, 21).Resize(, UBound(arr2) + 1).Value = arr2
    
30.             '            Cells(m, 20) = p & " " & p1
    
31.         Else
    
32.             Cells(m, 20) = p    '--------------
    
33.             arr2 = Split(p, " ")
    
34.             '            Cells(m, 21).Resize(, UBound(arr2) + 1).Value = arr2
    
35.             '            Cells(m, 20) = p & " " & p1
    
36.         End If
    
37.         Cells(m, 21).Resize(, UBound(arr2) + 1).Value = arr2
    
38.         Cells(m, 20) = p & " " & p1
    
39.     Next m
    
40.     Set d1 = Nothing
    
41.     Application.ScreenUpdating = True
    
42. End Sub
    

复制代码

hwc2ycy

代码基本没动，只动了输出的二行。

yvll

hwc2ycy 发表于 2014-2-23 22:16

非常感谢 hwc2ycy 老师，非常好，再次感谢！