如何根据成绩自动生成成绩分析报表

cqfdrslyh

要求

1. 一段（15%）计10分，二段（20%）计8分、三段（25%）计5分、四段（30%）计3分、五段（10%）计1分，如五段中各段最后一名出现并列情况，均计入该段。

2. 成绩录入后，根据《各段点一览表》模板生成数据并填写在表里.

3. 多个单元成绩分析就生成多个电子表模板，并自动生成报表。

4. 总积分=E+F+G+H+I

5. 生均积分=总积分/参评人数

6. 名次是根据同学科生均积分从高到低排名次

蓝桥玄霜

一段、二段的成绩怎么划分？

chxw68

猜测应该是按百分比划分分数段，然后按分数段内人数乘以得分计分的。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   mcd = [{0.15,0.35,0.5,0.8,1;10,8,5,3,1}]
   
7.   With Worksheets("学生成绩统计册")
   
8.     .AutoFilterMode = False
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     c = .Cells(3, .Columns.Count).End(xlToLeft).Column
    
11.     arr = .Range("a2").Resize(r - 1, c)
    
12.   End With
    
13.   s = 0
    
14.   For j = 5 To UBound(arr, 2) Step 2
    
15.     Set d(arr(1, j)) = CreateObject("scripting.dictionary")
    
16.     ReDim fsd(1 To UBound(mcd, 2))
    
17.     For i = 1 To UBound(mcd, 2)
    
18.       fsd(i) = Application.Large(Application.Index(arr, 0, j), (UBound(arr) - 2) * mcd(1, i))
    
19.     Next
    
20.     For i = 3 To UBound(arr)
    
21.       If Not d(arr(1, j)).exists(arr(i, 1)) Then
    
22.         ReDim brr(1 To 12)
    
23.         brr(1) = arr(1, j)
    
24.         brr(2) = arr(i, 1)
    
25.         s = s + 1
    
26.       Else
    
27.         brr = d(arr(1, j))(arr(i, 1))
    
28.       End If
    
29.       brr(4) = brr(4) + 1
    
30.       n = Application.Match(arr(i, j), fsd, -1)
    
31.       If Not IsError(n) Then
    
32.         brr(n + 4) = brr(n + 4) + 1
    
33.       End If
    
34.       d(arr(1, j))(arr(i, 1)) = brr
    
35.     Next
    
36.   Next
    
37.   ReDim crr(1 To s, 1 To 12)
    
38.   m = 0
    
39.   For Each aa In d.keys
    
40.     For Each bb In d(aa).keys
    
41.       brr = d(aa)(bb)
    
42.       For j = 1 To UBound(mcd, 2)
    
43.         If Len(brr(j + 4)) <> 0 Then
    
44.           brr(j + 4) = brr(j + 4) * mcd(2, j)
    
45.           brr(10) = brr(10) + brr(j + 4)
    
46.         End If
    
47.       Next
    
48.       If Len(brr(4)) <> 0 And brr(4) <> 0 Then
    
49.         brr(11) = Round(brr(10) / brr(4), 2)
    
50.       End If
    
51.       m = m + 1
    
52.       For j = 1 To UBound(brr)
    
53.         crr(m, j) = brr(j)
    
54.       Next
    
55.     Next
    
56.   Next
    
57.   With Worksheets("各段点一览表")
    
58.     .UsedRange.Offset(4, 0).Clear
    
59.     With .Range("a5").Resize(UBound(crr), UBound(crr, 2))
    
60.       .Value = crr
    
61.       .Borders.LineStyle = xlContinuous
    
62.     End With
    
63.     With .UsedRange
    
64.       .HorizontalAlignment = xlCenter
    
65.       .VerticalAlignment = xlCenter
    
66.     End With
    
67.   End With
    
68. End Sub
    

复制代码

chxw68

猜测着写的，结果不一定正确。

cqfdrslyh

chxw68 发表于 2021-9-26 10:49

非常感谢你的帮助。
现在只是五分段的意思我没表达清楚。
五分段中15%,35%,60%,90%,100%是指
先将成绩进行排名，再按总人数的前15%记10分，依次再按总人数的前35%记8分，按这样记分下去。
我试了一下，统计结果有出入

chxw68

cqfdrslyh 发表于 2021-9-28 21:07
非常感谢你的帮助。
现在只是五分段的意思我没表达清楚。
五分段中15%,35%,60%,90%,100%是指

没看明白你的规则，代码仅供参考。

yanjie

没有看明白！