Excel班级总分、年级排名、班级排名、输出到分班表的代码

358522643

各位大神，谢谢你们抽空帮忙看一下学生成绩统计表，需要Excel班级总分、年级排名、班级排名、输出到分班表的代码，谢谢大神们帮忙写一下！

358522643

忘记传附件了

358522643

各位大神帮帮忙啊！

不知道为什么

358522643 发表于 2018-7-19 21:57
各位大神帮帮忙啊！

http://club.excelhome.net/forum. ... ead&tid=1424239

褚老师的贴子，看完就能解决了哈

opiona

69楼：http://club.excelhome.net/thread-1409141-1-1.html

358522643

谢谢大神们的指引！万分感谢！

358522643

不知道为什么 发表于 2018-7-19 22:10
http://club.excelhome.net/forum.php?mod=viewthread&tid=1424239

褚老师的贴子，看完就能解决了哈

嗯嗯，学习中

358522643

不要不要的呀，问题没有解决哟，由于工作需要，我的表格和他那不一样，谢谢哪位大神帮写一下呀，我是小白，小白，小白……

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("总成绩表")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     .Range("l2:n" & r).ClearContents
    
12.     arr = .Range("a1:n" & r)
    
13.     For i = 2 To UBound(arr)
    
14.       For j = 4 To 11
    
15.         arr(i, 12) = arr(i, 12) + arr(i, j)
    
16.       Next
    
17.       d(arr(i, 12)) = d(arr(i, 12)) + 1
    
18.       If Not d1.exists(arr(i, 1)) Then
    
19.         Set d1(arr(i, 1)) = CreateObject("scripting.dictionary")
    
20.       End If
    
21.       d1(arr(i, 1))(arr(i, 12)) = d1(arr(i, 1))(arr(i, 12)) + 1
    
22.     Next
    
23.     nn = 1
    
24.     kk = d.keys
    
25.     For k = 0 To UBound(kk)
    
26.       mm = Application.Large(kk, k + 1)
    
27.       ss = d(mm)
    
28.       d(mm) = nn
    
29.       nn = nn + ss
    
30.     Next
    
31.     For Each aa In d1.keys
    
32.       nn = 1
    
33.       kk = d1(aa).keys
    
34.       For k = 0 To UBound(kk)
    
35.         mm = Application.Large(kk, k + 1)
    
36.         ss = d1(aa)(mm)
    
37.         d1(aa)(mm) = nn
    
38.         nn = nn + ss
    
39.       Next
    
40.     Next
    
41.     For i = 2 To UBound(arr)
    
42.       arr(i, 13) = d(arr(i, 12))
    
43.       arr(i, 14) = d1(arr(i, 1))(arr(i, 12))
    
44.     Next
    
45.     .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
46.     d.RemoveAll
    
47.     d1.RemoveAll
    
48.     For i = 2 To UBound(arr)
    
49.       bj = CStr(arr(i, 1))
    
50.       If Not d.exists(bj) Then
    
51.         Set d(bj) = .Range("a1:n1")
    
52.       End If
    
53.       Set d(bj) = Union(d(bj), .Cells(i, 1).Resize(1, 14))
    
54.     Next
    
55.   End With
    
56.   For Each aa In d.keys
    
57.     On Error Resume Next
    
58.     Set ws = Worksheets(aa & "班")
    
59.     If Err Then
    
60.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
61.       ws.Name = aa & "班"
    
62.     End If
    
63.     On Error GoTo 0
    
64.     With Worksheets(aa & "班")
    
65.       .Cells.Clear
    
66.       d(aa).Copy .Range("a1")
    
67.     End With
    
68.   Next
    
69.   Application.ScreenUpdating = True
    
70.   MsgBox "数据拆分完毕！"
    
71. End Sub
    

复制代码