年级成绩统计

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:i" & r)
   
9.   End With
   
10.   For i = 2 To UBound(arr)
    
11.     If Not d.exists(arr(i, 1)) Then
    
12.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
13.     End If
    
14.     For j = 4 To 6
    
15.       If Not d(arr(i, 1)).exists(arr(1, j)) Then
    
16.         ReDim brr(1 To 20)
    
17.         brr(1) = arr(1, j)
    
18.       Else
    
19.         brr = d(arr(i, 1))(arr(1, j))
    
20.       End If
    
21.       brr(2) = brr(2) + 1
    
22.       If Len(arr(i, j)) <> 0 Then
    
23.         brr(3) = brr(3) + 1
    
24.         brr(5) = brr(5) + arr(i, j)
    
25.         If arr(i, j) >= 80 Then
    
26.           brr(7) = brr(7) + 1
    
27.         End If
    
28.         If arr(i, j) >= 60 Then
    
29.           brr(9) = brr(9) + 1
    
30.         End If
    
31.         If IsEmpty(brr(11)) Then
    
32.           brr(11) = arr(i, j)
    
33.         Else
    
34.           If brr(11) < arr(i, j) Then
    
35.             brr(11) = arr(i, j)
    
36.           End If
    
37.         End If
    
38.         If IsEmpty(brr(12)) Then
    
39.           brr(12) = arr(i, j)
    
40.         Else
    
41.           If brr(12) > arr(i, j) Then
    
42.             brr(12) = arr(i, j)
    
43.           End If
    
44.         End If
    
45.         n = Application.Match(arr(i, j), Array(0, 40, 50, 60, 70, 80, 90, 100))
    
46.         If Not IsError(n) Then
    
47.           brr(21 - n) = brr(21 - n) + 1
    
48.         End If
    
49.         d(arr(i, 1))(arr(1, j)) = brr
    
50.       End If
    
51.     Next
    
52.   Next
    
53.   With Worksheets("统计")
    
54.     .Cells.Clear
    
55.     m = 1
    
56.     For Each aa In d.keys
    
57.       With .Cells(m, 1)
    
58.         .Value = aa & "班成绩统计表"
    
59.         .Resize(1, 20).Merge
    
60.         With .Font
    
61.           .Size = 18
    
62.           .Bold = True
    
63.         End With
    
64.       End With
    
65.       m = m + 1
    
66.       m0 = m
    
67.       .Cells(m, 1).Resize(1, 20) = [{"科目","应考人数","参考人数","参考率(%)","总分","平均分","优秀人数","优秀率(%)","及格人数","及格率(%)","最高分","最低分",100,"90－99.5","80－89.5","70－79.5","60－69.5","50－59.5","40－49.5","39.5以下"}]
    
68.       For Each bb In d(aa).keys
    
69.         m = m + 1
    
70.         brr = d(aa)(bb)
    
71.         If Len(brr(2)) <> 0 And brr(2) <> 0 Then
    
72.           brr(4) = Round(brr(3) / brr(2), 4)
    
73.         End If
    
74.         If Len(brr(3)) <> 0 And brr(3) <> 0 Then
    
75.           brr(6) = Round(brr(5) / brr(3), 2)
    
76.           brr(8) = Round(brr(7) / brr(3), 4)
    
77.           brr(10) = Round(brr(9) / brr(3), 4)
    
78.         End If
    
79.         .Cells(m, 1).Resize(1, UBound(brr)) = brr
    
80.       Next
    
81.       .Cells(m0, 1).Resize(m - m0 + 1, 20).Borders.LineStyle = xlContinuous
    
82.       m = m + 2
    
83.     Next
    
84.     .Range("d:d,h:h,j:j").NumberFormatLocal = "0.00%"
    
85.     With .UsedRange
    
86.       .HorizontalAlignment = xlCenter
    
87.       .VerticalAlignment = xlCenter
    
88.     End With
    
89.    
    
90.   End With
    
91. End Sub
    

复制代码

chxw68

凑个热闹。

ypcf0312

chxw68 发表于 2018-9-17 22:39
凑个热闹。

老师您好：应考人数是每班有名字的所有人，参考人数是成绩不为0的人数。代码运行后，两者分辨不出，如4班应考人数应为42，参考人数是41，要在哪里改？

chxw68

ypcf0312 发表于 2018-9-17 23:25
老师您好：应考人数是每班有名字的所有人，参考人数是成绩不为0的人数。代码运行后，两者分辨不出，如4班 ...

这个好修改！我想问一下考0分的与缺考的人员怎么区分？

chxw68

ypcf0312 发表于 2018-9-17 23:25
老师您好：应考人数是每班有名字的所有人，参考人数是成绩不为0的人数。代码运行后，两者分辨不出，如4班 ...

一般都是缺考的成绩为空。

ypcf0312

缺考的区分是在成绩区域填上“缺考”

chxw68

ypcf0312 发表于 2018-9-18 11:00
缺考的区分是在成绩区域填上“缺考”

你不是说的：参考人数是成绩不为0的人数。怎么缺考又变成成绩区域为“缺考”的了？

ypcf0312

chxw68 发表于 2018-9-18 11:03
你不是说的：参考人数是成绩不为0的人数。怎么缺考又变成成绩区域为“缺考”的了？

不好意思，我表达错了。参考人数是成绩不为0的人数，应考人数为班级里有人名的就可以，如果某科缺考的话，可用空格表示或填上“缺考”