请大侠帮忘，如何排名

烟松粼

请大侠帮忘，如何排名

按总分按年级班次排校名，班名
按科目分数按年级排校名

谢谢大侠

ctp_119

你要怎么排名？你都不说，怎么知道？是按照总分排名，还是班级，还是按学校班级排名？

烟松粼

ctp_119 发表于 2015-5-27 10:21
你要怎么排名？你都不说，怎么知道？是按照总分排名，还是班级，还是按学校班级排名？

不好意思呀，忘了
按总分排校名、班名
按科目分排校名

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, 1).End(xlUp).Row
   
8.     arr = .Range("a2:ac" & r)
   
9.     For j = 7 To UBound(arr, 2) - 2 Step 2
   
10.       d.RemoveAll
    
11.       For i = 1 To UBound(arr)
    
12.         If Len(arr(i, j)) <> 0 Then
    
13.           d(arr(i, j)) = d(arr(i, j)) + 1
    
14.         End If
    
15.       Next
    
16.       nn = 1
    
17.       kk = d.keys
    
18.       For k = 0 To UBound(kk)
    
19.         mm = Application.Large(kk, k + 1)
    
20.         ss = d(mm)
    
21.         d(mm) = nn
    
22.         nn = nn + ss
    
23.       Next
    
24.       For i = 1 To UBound(arr)
    
25.         arr(i, j + 1) = ""
    
26.         If Len(arr(i, j)) <> 0 Then
    
27.           arr(i, j + 1) = d(arr(i, j))
    
28.         End If
    
29.       Next
    
30.     Next
    
31.     d.RemoveAll
    
32.     For i = 1 To UBound(arr)
    
33.       If Len(arr(i, 27)) <> 0 Then
    
34.         If Not d.exists(arr(i, 2)) Then
    
35.           Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
36.         End If
    
37.         d(arr(i, 2))(arr(i, 27)) = d(arr(i, 2))(arr(i, 27)) + 1
    
38.       End If
    
39.     Next
    
40.     For Each aa In d.keys
    
41.       nn = 1
    
42.       kk = d(aa).keys
    
43.       For k = 0 To UBound(kk)
    
44.         mm = Application.Large(kk, k + 1)
    
45.         ss = d(aa)(mm)
    
46.         d(aa)(mm) = nn
    
47.         nn = nn + ss
    
48.       Next
    
49.     Next
    
50.     For i = 1 To UBound(arr)
    
51.       If Len(arr(i, 27)) <> 0 Then
    
52.         arr(i, 29) = d(arr(i, 2))(arr(i, 27))
    
53.       End If
    
54.     Next
    
55.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
56.   End With
    
57. End Sub
    
58. 
    

复制代码

chxw68

详见附件。

ctp_119

这样的问题，我建议用透视表最简单了。。。无需用代码

烟松粼

chxw68 发表于 2015-5-27 11:05
详见附件。

能加上注释呀
大侠你好，
  我运行了下，发现是以总分排名，没有考虑年级的因素
这是我的失误，没注明要求
能请你改一下吗：
               以总分按年级、班次排校名、班名，
               以科目分数排校名

dgy5201314

chxw68 发表于 2015-5-27 11:05
详见附件。

求大侠帮忙，http://club.excelhome.net/thread-1207684-1-1.html

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, 1).End(xlUp).Row
   
8.     arr = .Range("a2:ac" & r)
   
9.     For j = 7 To UBound(arr, 2) - 2 Step 2
   
10.       d.RemoveAll
    
11.       For i = 1 To UBound(arr)
    
12.         If Len(arr(i, j)) <> 0 Then
    
13.           If Not d.exists(arr(i, 1)) Then
    
14.             Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.           End If
    
16.           d(arr(i, 1))(arr(i, j)) = d(arr(i, 1))(arr(i, j)) + 1
    
17.         End If
    
18.       Next
    
19.       For Each aa In d.keys
    
20.         nn = 1
    
21.         kk = d(aa).keys
    
22.         For k = 0 To UBound(kk)
    
23.           mm = Application.Large(kk, k + 1)
    
24.           ss = d(aa)(mm)
    
25.           d(aa)(mm) = nn
    
26.           nn = nn + ss
    
27.         Next
    
28.         For i = 1 To UBound(arr)
    
29.           arr(i, j + 1) = ""
    
30.           If Len(arr(i, j)) <> 0 Then
    
31.             arr(i, j + 1) = d(arr(i, 1))(arr(i, j))
    
32.           End If
    
33.         Next
    
34.       Next
    
35.     Next
    
36.     d.RemoveAll
    
37.     For i = 1 To UBound(arr)
    
38.       If Len(arr(i, 27)) <> 0 Then
    
39.         If Not d.exists(arr(i, 1)) Then
    
40.           Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
41.         End If
    
42.         If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
43.           Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
    
44.         End If
    
45.         d(arr(i, 1))(arr(i, 2))(arr(i, 27)) = d(arr(i, 1))(arr(i, 2))(arr(i, 27)) + 1
    
46.       End If
    
47.     Next
    
48.     For Each aa In d.keys
    
49.       For Each bb In d(aa).keys
    
50.         nn = 1
    
51.         kk = d(aa)(bb).keys
    
52.         For k = 0 To UBound(kk)
    
53.           mm = Application.Large(kk, k + 1)
    
54.           ss = d(aa)(bb)(mm)
    
55.           d(aa)(bb)(mm) = nn
    
56.           nn = nn + ss
    
57.         Next
    
58.       Next
    
59.     Next
    
60.     For i = 1 To UBound(arr)
    
61.       If Len(arr(i, 27)) <> 0 Then
    
62.         arr(i, 29) = d(arr(i, 1))(arr(i, 2))(arr(i, 27))
    
63.       End If
    
64.     Next
    
65.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
66.   End With
    
67. End Sub
    
68. 
    

复制代码

chxw68

前面没细看楼主的数据，以为整个就是一个年级的数据，现在修改好了。这段代码中主要使用了字典嵌套，楼主如果没有这方面的基础，注释了可能理解起来也比较吃力。