成绩统计的求和与排名

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim ws As Worksheet
   
5.   Dim d As Object
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   Set d1 = CreateObject("scripting.dictionary")
   
10.   For Each ws In Worksheets
    
11.     If ws.Name Like "*年级" Then
    
12.       d.RemoveAll
    
13.       d1.RemoveAll
    
14.       With ws
    
15.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
16.         .Range("k3:m" & r).ClearContents
    
17.         arr = .Range("a3:m" & r)
    
18.         For i = 1 To UBound(arr)
    
19.           bj = Mid(arr(i, 5), 2)
    
20.           For j = 6 To 10
    
21.             arr(i, 11) = arr(i, 11) + arr(i, j)
    
22.           Next
    
23.           If Not d.exists(bj) Then
    
24.             Set d(bj) = CreateObject("scripting.dictionary")
    
25.           End If
    
26.           d(bj)(arr(i, 11)) = d(bj)(arr(i, 11)) + 1
    
27.           d1(arr(i, 11)) = d1(arr(i, 11)) + 1
    
28.         Next
    
29.         For Each aa In d.keys
    
30.           nn = 1
    
31.           kk = d(aa).keys
    
32.           For k = 0 To UBound(kk)
    
33.             mm = Application.Large(kk, k + 1)
    
34.             ss = d(aa)(mm)
    
35.             d(aa)(mm) = nn
    
36.             nn = ss + nn
    
37.           Next
    
38.         Next
    
39.         nn = 1
    
40.         kk = d1.keys
    
41.         For k = 0 To UBound(kk)
    
42.           mm = Application.Large(kk, k + 1)
    
43.           ss = d1(mm)
    
44.           d1(mm) = nn
    
45.           nn = ss + nn
    
46.         Next
    
47.         For i = 1 To UBound(arr)
    
48.           bj = Mid(arr(i, 5), 2)
    
49.           arr(i, 12) = d(bj)(arr(i, 11))
    
50.           arr(i, 13) = d1(arr(i, 11))
    
51.         Next
    
52.         .Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr
    
53.       End With
    
54.     End If
    
55.   Next
    
56.   Application.ScreenUpdating = True
    
57.   MsgBox "成绩统计完毕！"
    
58. End Sub
    
59. 
    

复制代码

chxw68

详见附件。