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

chxw68 · 发表于 2020-7-20 20:52

班级排名代码稍微改一下就可以统计学校排名。

Sub test5()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Call pub
For Each ws In Worksheets(Array("七年级", "八年级", "九年级"))
With ws
Set d(ws.Name) = CreateObject("scripting.dictionary")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
d1(ws.Name) = .Range("e2").Resize(1, c - 4)
arr = .Range("a2").Resize(r - 1, c + 1)
arr(1, UBound(arr, 2)) = "全科"
For i = 2 To UBound(arr)
For j = 5 To UBound(arr, 2) - 1
arr(i, j) = Val(arr(i, j))
arr(i, UBound(arr, 2)) = arr(i, UBound(arr, 2)) + arr(i, j)
Next
Next
ls = 8
For i = 2 To UBound(arr)
bj = arr(i, 1)
If Not d(ws.Name).exists(bj) Then
ReDim brr(1 To ls)
brr(1) = bj
Else
brr = d(ws.Name)(bj)
End If
brr(2) = brr(2) + 1
jgkm = 0
yxkm = 0
For j = 5 To UBound(arr, 2) - 1
If Len(arr(i, j)) <> 0 Then
brr(3) = brr(3) + arr(i, j)
End If
If d_3f.exists(ws.Name) Then
If d_3f(ws.Name).exists(arr(1, j)) Then
If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("及格分") Then
jgkm = jgkm + 1
End If
End If
If InStr("语文数学英语物理", arr(1, j)) <> 0 Then
If d_3f(ws.Name).exists(arr(1, j)) Then
If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("优秀分") Then
yxkm = yxkm + 1
End If
End If
End If
End If
Next
If jgkm = UBound(arr, 2) - 5 Then
brr(4) = brr(4) + 1
End If
If yxkm = IIf(ws.Name = "七年级", 3, 4) Then
brr(6) = brr(6) + 1
End If
If d_3f.exists(ws.Name) Then
If d_3f(ws.Name).exists("全科") Then
If arr(i, UBound(arr, 2)) >= d_3f(ws.Name)("全科")("关爱分") Then
brr(5) = brr(5) + 1
End If
End If
End If
d(ws.Name)(bj) = brr
Next
End With
Next
On Error Resume Next
Worksheets("学校排名").Delete
On Error GoTo 0
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = "学校排名"
With .Range("a1")
.Value = "学校排名"
.Resize(1, 24).Merge
With .Font
.Name = "微软雅黑"
.Size = 18
End With
End With
n = 1
For Each aa In d.keys
d2.RemoveAll
bt = d1(aa)
With .Cells(2, n)
.Value = aa
.Resize(1, 8).Merge
End With
.Cells(3, n).Resize(1, 8) = Array("学校班级", "与考" & vbLf & "人数", "平均" & vbLf & "分", "全科" & vbLf & "合格率", "关爱" & vbLf & "率", IIf(aa = "七年级", "三科", "四科") & vbLf & "优秀率", "四率" & vbLf & "合计", "排名")
ReDim crr(1 To d(aa).Count, 1 To 8)
ReDim drr(1 To 8)
drr(1) = "区平均"
m = 0
For Each bb In d(aa).keys
brr = d(aa)(bb)
m = m + 1
For j = 1 To UBound(brr)
crr(m, j) = brr(j)
Next
For j = 2 To 6
drr(j) = drr(j) + brr(j)
Next
Next
For i = 1 To UBound(crr)
If Len(crr(i, 2)) <> 0 And crr(i, 2) <> 0 Then
crr(i, 3) = Round(crr(i, 3) / crr(i, 2) / UBound(bt, 2), 2)
crr(i, 4) = Round(crr(i, 4) / crr(i, 2), 4)
crr(i, 5) = Round(crr(i, 5) / crr(i, 2), 4)
crr(i, 6) = Round(crr(i, 6) / crr(i, 2), 4)
crr(i, 7) = Round(crr(i, 3) * 0.3 + crr(i, 4) * 0.3 * 100 + crr(i, 5) * 0.2 * 100 + crr(i, 6) * 0.2 * 100, 2)
d2(crr(i, 7)) = d2(crr(i, 7)) + 1
End If
Next
nn = 1
kk = d2.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d2(mm)
d2(mm) = nn
nn = nn + ss
Next
For i = 1 To UBound(crr)
If Len(crr(i, 7)) <> 0 Then
crr(i, 8) = d2(crr(i, 7))
End If
Next
If Len(drr(2)) <> 0 And drr(2) <> 0 Then
drr(3) = Round(drr(3) / drr(2) / UBound(bt, 2), 2)
drr(4) = Round(drr(4) / drr(2), 4)
drr(5) = Round(drr(5) / drr(2), 4)
drr(6) = Round(drr(6) / drr(2), 4)
drr(7) = Round(drr(3) * 0.3 + drr(4) * 0.3 * 100 + drr(5) * 0.2 * 100 + drr(6) * 0.2 * 100, 2)
d2(drr(7)) = d2(drr(7)) + 1
End If
.Cells(4, n).Resize(1, UBound(drr)) = drr
.Cells(5, n).Resize(UBound(crr), UBound(crr, 2)) = crr
With .Cells(2, n).Resize(2 + 1 + UBound(crr), UBound(crr, 2))
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
n = n + 8
Next
c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
For j = 1 To c Step 8
.Columns(j + 3).Resize(, 3).NumberFormatLocal = "0.00%"
Next
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.UsedRange.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "学校排名计算完毕！"
End Sub

复制代码

chxw68 · 发表于 2020-7-20 20:53

增加了学校排名代码。现在就剩教师排名了。

jiangxiaoyun · 发表于 2020-7-20 20:57

用函数写比vba好多了。

cqcbc · 发表于 2020-7-20 21:05

chxw68 发表于 2020-7-20 20:53
增加了学校排名代码。现在就剩教师排名了。

不错，还有教师考核排名，就完美了。

chxw68 · 发表于 2020-7-20 21:05

cqcbc 发表于 2020-7-20 21:05
不错，还有教师考核排名，就完美了。

教师排名没样表没说明，不知道要求是什么。

辛玛 · 发表于 2020-7-20 21:10

本帖最后由辛玛于 2020-7-20 21:14 编辑

chxw68 发表于 2020-7-20 20:47
增加了班级排名代码。其他的楼主也没样表，不知道怎么写了。

老师排名

辛玛 · 发表于 2020-7-20 21:16

chxw68 发表于 2020-7-20 21:05
教师排名没样表没说明，不知道要求是什么。

辛苦老师了，今天我已无法上传更多附件了，被系统限制了，还有一个学校排名的没传成功。

cqcbc · 发表于 2020-7-20 21:24

辛玛发表于 2020-7-20 21:16
辛苦老师了，今天我已无法上传更多附件了，被系统限制了，还有一个学校排名的没传成功。

我们这里考核的是五项：参考率、平均分、及格率、优生率、低分率。

辛玛 · 发表于 2020-7-20 21:42

cqcbc 发表于 2020-7-20 21:24
我们这里考核的是五项：参考率、平均分、及格率、优生率、低分率。

老师，你是哪个地区的？

辛玛 · 发表于 2020-7-20 21:46

chxw68 发表于 2020-7-20 21:05
教师排名没样表没说明，不知道要求是什么。

chxw68老师，教师排名主要计算下面几项。
科目教师姓名任教班级总人数平均分及格率关爱率三率评估分排名

因为有的老师是任教同年级同科目几个班的，所以这里是求这个老师同年级同科目的几个班的平均值。

		自动登录	找回密码
密码			免费注册

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

评分

评分