一分两率计算各班各学科平均分、合格率、优秀率

microyip

同样的东西，在论坛里也有很多案例，搜索抄一下就是啦

behan

chxw68 发表于 2017-11-2 11:01
把楼主表格结构修改了一下，增加了一个[教师任课表]，代码根据[一分两率]和[教师任课表]自动生成[教师一分 ...

非常感谢大神的帮忙，谢谢！

behan

chxw68 发表于 2017-11-2 11:01
把楼主表格结构修改了一下，增加了一个[教师任课表]，代码根据[一分两率]和[教师任课表]自动生成[教师一分 ...

非常感谢大神的帮忙，谢谢！我只要修改教师任课表就可以计算其他年级吗？

huang1314wei

1. Sub test()
   
2.     Dim d As Object, arr, i%, j%, rng As Range, crr, n%
   
3.     Dim c, c1, c2, brr(1 To 100000, 1 To 7), drr()
   
4.     Dim 总人数, 总分, 合格人数, 优秀人数, y
   
5.     On Error GoTo L
   
6.     arr = Sheet1.Range("A1").CurrentRegion
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     For i = 2 To UBound(arr)
   
10.         If Not d.exists(arr(i, 2)) Then
    
11.             Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
12.         End If
    
13.         If Not d(arr(i, 2)).exists(arr(i, 1)) Then
    
14.             Set d(arr(i, 2))(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.         End If
    
16.         d(arr(i, 2))(arr(i, 1))(arr(i, 3)) = ""
    
17.     Next
    
18.     n = 1
    
19.     brr(n, 1) = "科目": brr(n, 2) = "姓名": brr(n, 3) = "班别"
    
20.     brr(n, 4) = "平均分": brr(n, 5) = "合格率": brr(n, 6) = "优秀率"
    
21.     brr(n, 7) = "平均分排名"
    
22.     For Each c In d.keys
    
23.         Set rng = Sheet3.Cells.Find(c, lookat:=xlPart)
    
24.         crr = rng.CurrentRegion
    
25.         总人数 = 0: 总分 = 0
    
26.         合格人数 = 0: 优秀人数 = 0
    
27.         For Each c1 In d(c).keys
    
28.             n = n + 1
    
29.             j = j + 1
    
30.             brr(n, 1) = c
    
31.             brr(n, 2) = c1
    
32.             brr(n, 3) = Join(d(c)(c1).keys, "、")
    
33.             For Each c2 In d(c)(c1).keys
    
34.                 总人数 = 总人数 + crr(c2 + 2, 2)
    
35.                 总分 = 总分 + crr(c2 + 2, 3)
    
36.                 合格人数 = 合格人数 + crr(c2 + 2, 5)
    
37.                 优秀人数 = 优秀人数 + crr(c2 + 2, 7)
    
38.             Next
    
39.             ReDim Preserve drr(j - 1)
    
40.             brr(n, 4) = Round(总分 / 总人数, 2)
    
41.             drr(j - 1) = brr(n, 4)
    
42.             brr(n, 5) = Round(合格人数 / 总人数, 4) * 100
    
43.             brr(n, 6) = Round(优秀人数 / 总人数, 4) * 100
    
44.         Next
    
45.         For y = n To n - j + 1 Step -1
    
46.             brr(y, 7) = PM(brr(y, 4), drr)
    
47.         Next
    
48.         j = 0
    
49.         n = n + 2
    
50.         brr(n, 1) = "科目": brr(n, 2) = "姓名": brr(n, 3) = "班别"
    
51.         brr(n, 4) = "平均分": brr(n, 5) = "合格率": brr(n, 6) = "优秀率"
    
52.         brr(n, 7) = "平均分排名"
    
53. L:    Next
    
54.     Sheet2.Cells.Clear
    
55.     Sheet2.Range("A1").Resize(n, 7) = brr
    
56.     Sheet2.Columns().AutoFit
    
57.     Sheet2.Cells.HorizontalAlignment = xlCenter
    
58.     Sheet2.Rows(n).Delete
    
59.     For Each rng In Sheet2.Range("A1:A" & n)
    
60.         If rng.Value <> "" Then rng.CurrentRegion.Borders.LineStyle = 1
    
61.     Next
    
62.     Sheet2.Select
    
63. End Sub
    
64. 
    
65. Function PM(ByVal x1 As Double, ByVal arr As Variant) As Integer
    
66.     Dim n%, x%
    
67.     For x = 0 To UBound(arr)
    
68.         If arr(x) >= x1 Then
    
69.             n = n + 1
    
70.         End If
    
71.     Next
    
72.     PM = n
    
73. End Function
    

复制代码

huang1314wei

附件参考

初三级一分两率.rar (22.38 KB, 下载次数: 160)

2017-11-2 11:21 上传

点击文件名下载附件

chxw68

behan 发表于 2017-11-2 11:12
非常感谢大神的帮忙，谢谢！我只要修改教师任课表就可以计算其他年级吗？

是这样的。

eing888

帮我解决了大问题，谢谢

zhuql2921

老师，如果是这样的呢

zhuql2921

加了分工分课表了

chxw68

zhuql2921 发表于 2021-11-20 09:16
加了分工分课表了

楼主这是帮助贴呢还是求助贴呢？不打开附件真的不明白！新问题最好开新贴，不要寄存在别人贴子里了。仔细看了楼主的需要，可能是要生成教师分析表，但前面有的表是七年级的，有的只有班级没有年级，而任课教师表却是八年级的，对不上。