这样的高难度成绩分析可能只有求助老师们了

chxw68

教师排名代码。

1. Sub test6()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, crr(), drr()
   
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.   Set d2 = CreateObject("scripting.dictionary")
   
10.   Call pub
    
11.   For Each ws In Worksheets(Array("七年级", "八年级", "九年级"))
    
12.     With ws
    
13.       Set d(ws.Name) = CreateObject("scripting.dictionary")
    
14.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
15.       c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
16.       arr = .Range("a2").Resize(r - 1, c)
    
17.       For i = 2 To UBound(arr)
    
18.         For j = 5 To UBound(arr, 2)
    
19.           arr(i, j) = Val(arr(i, j))
    
20.         Next
    
21.       Next
    
22.       
    
23.       ls = 9
    
24.       For j = 5 To UBound(arr, 2)
    
25.         Set d(ws.Name)(arr(1, j)) = CreateObject("scripting.dictionary")
    
26.         For i = 2 To UBound(arr)
    
27.           bj = arr(i, 1) & arr(i, 2)
    
28.           If d_js.exists(bj) Then
    
29.             If d_js(bj).exists(arr(1, j)) Then
    
30.               js = d_js(bj)(arr(1, j))
    
31.               If Not d(ws.Name)(arr(1, j)).exists(js) Then
    
32.                 ReDim brr(1 To ls)
    
33.                 brr(1) = arr(1, j)
    
34.                 brr(2) = js
    
35.                 Set brr(3) = CreateObject("scripting.dictionary")
    
36.               Else
    
37.                 brr = d(ws.Name)(arr(1, j))(js)
    
38.               End If
    
39.               brr(3)(arr(i, 2)) = ""
    
40.               If Len(arr(i, j)) <> 0 Then
    
41.                 brr(4) = brr(4) + 1
    
42.                 brr(5) = brr(5) + arr(i, j)
    
43.                 If d_3f.exists(ws.Name) Then
    
44.                   If d_3f(ws.Name).exists(arr(1, j)) Then
    
45.                     If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("及格分") Then
    
46.                       brr(6) = brr(6) + 1
    
47.                     End If
    
48.                     If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("关爱分") Then
    
49.                       brr(7) = brr(7) + 1
    
50.                     End If
    
51.                   End If
    
52.                 End If
    
53.               End If
    
54.               d(ws.Name)(arr(1, j))(js) = brr
    
55.             End If
    
56.           End If
    
57.         Next
    
58.       Next
    
59.     End With
    
60.   Next
    
61.   On Error Resume Next
    
62.   Worksheets("教师排名").Delete
    
63.   On Error GoTo 0
    
64.   Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
65.   With ws
    
66.     .Name = "教师排名"
    
67.     n1 = 1
    
68.     For Each aa In d.keys
    
69.       i1 = 1
    
70.       .Columns(n1 + 2).NumberFormatLocal = "@"
    
71.       .Columns(n1 + 5).Resize(, 2).NumberFormatLocal = "0.00%"
    
72.       With .Cells(1, n1)
    
73.         .Value = aa & "教师排名"
    
74.         .Resize(1, 9).Merge
    
75.         With .Font
    
76.           .Name = "微软雅黑"
    
77.           .Size = 16
    
78.         End With
    
79.       End With
    
80.       With .Cells(2, n1).Resize(1, 9)
    
81.         .Value = Array("科目", "教师姓名", "任教班级", "总人数", "平均分", "及格率", "关爱率", "三率评估分", "排名")
    
82.         .Borders.LineStyle = xlContinuous
    
83.         .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    
84.         With .Font
    
85.           .Name = "微软雅黑"
    
86.           .Size = 11
    
87.         End With
    
88.       End With
    
89.         
    
90.       m = 0
    
91.       i1 = 3
    
92.       For Each bb In d(aa).keys
    
93.         d2.RemoveAll
    
94.         ReDim crr(1 To d(aa)(bb).Count, 1 To 9)
    
95.         m = 0
    
96.         For Each cc In d(aa)(bb).keys
    
97.           brr = d(aa)(bb)(cc)
    
98.           brr(3) = Join(brr(3).keys, ",")
    
99.           m = m + 1
    
100.           For j = 1 To UBound(brr)
     
101.             crr(m, j) = brr(j)
     
102.           Next
     
103.         Next
     
104.         For i = 1 To UBound(crr)
     
105.           If Len(crr(i, 4)) <> 0 And crr(i, 4) <> 0 Then
     
106.             crr(i, 5) = Round(crr(i, 5) / crr(i, 4), 2)
     
107.             crr(i, 6) = Round(crr(i, 6) / crr(i, 4), 4)
     
108.             crr(i, 7) = Round(crr(i, 7) / crr(i, 4), 4)
     
109.             crr(i, 8) = Round(crr(i, 5) * 0.4 + crr(i, 6) * 0.4 * 100 + crr(i, 7) * 0.2 * 100, 2)
     
110.             d2(crr(i, 8)) = d2(crr(i, 8)) + 1
     
111.           End If
     
112.         Next
     
113.         nn = 1
     
114.         kk = d2.keys
     
115.         For k = 0 To UBound(kk)
     
116.           mm = Application.Large(kk, k + 1)
     
117.           ss = d2(mm)
     
118.           d2(mm) = nn
     
119.           nn = nn + ss
     
120.         Next
     
121.         For i = 1 To UBound(crr)
     
122.           If Len(crr(i, 8)) <> 0 Then
     
123.             crr(i, 9) = d2(crr(i, 8))
     
124.           End If
     
125.         Next
     
126.         With .Cells(i1, n1).Resize(UBound(crr), UBound(crr, 2))
     
127.           .Value = crr
     
128.           .Borders.LineStyle = xlContinuous
     
129.           .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
     
130.           With .Font
     
131.             .Name = "微软雅黑"
     
132.             .Size = 11
     
133.           End With
     
134.         End With
     
135.         .Cells(i1, n1).Resize(UBound(crr), 1).Merge
     
136.         i1 = i1 + UBound(crr)
     
137.       Next
     
138.       n1 = n1 + 10
     
139.     Next
     
140.     With .UsedRange
     
141.       .HorizontalAlignment = xlCenter
     
142.       .VerticalAlignment = xlCenter
     
143.     End With
     
144.     .UsedRange.EntireColumn.AutoFit
     
145.   End With
     
146.   Application.ScreenUpdating = True
     
147.   MsgBox "教师排名计算完毕！"
     
148. End Sub

复制代码

chxw68

增加了教师排名代码。

辛玛

chxw68 发表于 2020-7-20 22:04
教师排名代码。

很完美！辛苦老师了，谢谢chxw68老师。

shuway

太厉害了！

辛玛

chxw68 发表于 2020-7-20 22:05
增加了教师排名代码。

chxw68老师，三率分析、到班分析能否做成打印版呢？

chxw68

修改好了。

chxw68

前面有的表就不需要了。

辛玛

chxw68 发表于 2020-7-21 16:23
前面有的表就不需要了。

谢谢chxw68老师，VBA好强大，chxw68老师，您实在太厉害了

辛玛

chxw68 发表于 2020-7-21 16:23
前面有的表就不需要了。

麻烦chxw68老师可否再加一个功能，凡是有区平均统计的表格，各对比数据的三率合计（四率合计）如果低于区平均三率或四率的80%，此单元格填充为红色，低于60%填充为黄色。

chxw68

你新来的可能不知道，这个论坛是学习交流的平台，不是找免费义工的地方，要学习自己动手，不能一味伸手。