Sub 成绩分析()
Application.ScreenUpdating = False
Dim ar As Variant
Dim brr(), br()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
rr = Array(8, 11, 14, 17, 20, 22)
With Sheets("设置")
mc = .[b1] & .[b2] & .[c2] & "学年度" & .[b3] & .[b4] & .[b5]
cr = .Range("e1:o6")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
crr = .Range("a7:b" & rs)
End With
For j = 2 To UBound(cr, 2)
d(cr(1, j)) = j
Next j
For i = 2 To UBound(crr)
d(crr(i, 1)) = crr(i, 2)
Next i
With Sheets("score")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 4 Then MsgBox "成绩表为空！": End
ar = .Range("a1:p" & r)
End With
With Sheets("成绩分析")
.UsedRange.Offset(3).UnMerge
.UsedRange.Offset(3).Font.Bold = False
.UsedRange.Offset(3).Font.Size = 11
.UsedRange.Offset(3).Font.ColorIndex = xlAutomatic
.UsedRange.Offset(3).Borders.LineStyle = 0
.UsedRange.Offset(3) = Empty
For i = 4 To UBound(ar, 1)
If ar(i, 3) <> "" Then
dic(ar(i, 3)) = dic(ar(i, 3)) + ar(i, 4)
zf = zf + ar(i, 4)
End If
Next i
For j = 7 To UBound(ar, 2)
k = 0: dc.RemoveAll
ReDim br(1 To UBound(ar), 1 To 22)
Erase brr
ReDim brr(1 To UBound(ar), 1 To 22)
brr(1, 1) = "学校全体"
lh = d(ar(2, j))
For i = 4 To UBound(ar, 1)
If ar(i, 4) <> "" Then
If IsNumeric(ar(i, 4)) Then
If ar(i, 4) > 0 Then
t = dc(ar(i, 3))
If t = "" Then
k = k + 1
dc(ar(i, 3)) = k
t = k
br(k, 1) = ar(i, 3) '''班级名称
br(k, 2) = d(ar(i, 3)) '''班主任
End If
br(t, 3) = br(t, 3) + 1 ''参考人数
brr(1, 3) = brr(1, 3) + 1 ''参考人数
If br(t, 4) = "" Then
br(t, 4) = ar(i, j)
ElseIf ar(i, j) > br(t, 4) Then
br(t, 4) = ar(i, j)
End If
'''最高分
If brr(1, 4) = "" Then
brr(1, 4) = ar(i, j)
ElseIf ar(i, j) > brr(1, 4) Then
brr(1, 4) = ar(i, j)
End If
'''最高分
If br(t, 5) = "" Then
br(t, 5) = ar(i, j)
ElseIf ar(i, j) < br(t, 5) Then
br(t, 5) = ar(i, j)
End If
'''最低分
If brr(1, 5) = "" Then
brr(1, 5) = ar(i, j)
ElseIf ar(i, j) < brr(1, 5) Then
brr(1, 5) = ar(i, j)
End If
'''最低分
br(t, 6) = br(t, 6) + ar(i, j) '''总分
brr(1, 6) = brr(1, 6) + ar(i, j) '''总分
If ar(i, j) >= cr(3, lh) Then
br(t, 9) = br(t, 9) + 1 ''优秀人数
brr(1, 9) = brr(1, 9) + 1 ''优秀人数
End If
If ar(i, j) >= cr(4, lh) Then
br(t, 12) = br(t, 12) + 1 ''良好人数
brr(1, 12) = brr(1, 12) + 1
End If
If ar(i, j) >= cr(5, lh) Then
br(t, 15) = br(t, 15) + 1 ''及格人数
brr(1, 15) = brr(1, 15) + 1
End If
If ar(i, j) <= cr(6, lh) Then
br(t, 18) = br(t, 18) + 1 ''低分人数
brr(1, 18) = brr(1, 18) + 1
End If
End If
End If
End If
Next i
For i = 1 To k
br(i, 7) = br(i, 6) / dic(br(i, 1)) ''平均分率
br(i, 6) = br(i, 6) / br(i, 3) ''平均分
br(i, 10) = br(i, 9) / br(i, 3) ''优秀率
br(i, 13) = br(i, 12) / br(i, 3) ''良好率
br(i, 16) = br(i, 15) / br(i, 3) ''及格率
br(i, 19) = br(i, 18) / br(i, 3) ''低分率
br(i, 21) = br(i, 7) * 0.3 + br(i, 10) * 0.1 + br(i, 13) * 0.2 + br(i, 16) * 0.3 + (1 - br(i, 19)) * 10
'综合率 = 平均分率 * 30 + 优秀率 * 10 + 良好率 * 20 + 及格率 * 30 + (1 - 低分率) * 10
Next i
brr(1, 7) = brr(1, 6) / zf
brr(1, 6) = brr(1, 6) / brr(1, 3)
brr(1, 10) = brr(1, 9) / brr(1, 3) ''优秀率
brr(1, 13) = brr(1, 12) / brr(1, 3) ''良好率
brr(1, 16) = brr(1, 15) / brr(1, 3) ''及格率
brr(1, 19) = brr(1, 18) / brr(1, 3) ''低分率
brr(1, 21) = brr(1, 7) * 0.3 + brr(1, 10) * 0.1 + brr(1, 13) * 0.2 + brr(1, 16) * 0.3 + (1 - brr(1, 19)) * 10
If j = 7 Then
ws = 1
Else
ws = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
If j > 7 Then .Rows("1:3").Copy .Cells(ws, 1)
.Cells(ws, 1) = "三率一分" & mc & "-" & ar(2, j)
.Cells(ws + 3, 1).Resize(1, UBound(brr, 2)) = brr
.Cells(ws + 4, 1).Resize(k, UBound(br, 2)) = br
.Cells(ws + 3, 1).Resize(k + 1, UBound(br, 2)).Borders.LineStyle = 1
For s = 0 To UBound(rr)
h = rr(s)
For i = ws + 4 To k + ws + 3
.Cells(i, h) = Application.Rank(.Cells(i, h - 1), .Range(.Cells(ws + 4, h - 1), .Cells(k + ws + 3, h - 1)))
If .Cells(i, 19) > .Cells(ws + 3, 19) Then .Cells(i, 19).Font.ColorIndex = 3
Next i
Next s
Next j
End With
Set d = Nothing
Set dc = Nothing
Set dic = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-17 18:19
楼主
