成绩统计

清茶一

本人有一份成绩，经常要统计，请问这代码怎么写，请各位高手帮忙下，谢谢啦

清风竹-

最关键的条件没有提供。总分多少是优秀、良好 …… ; 单科多少分是优秀、良好……

清茶一

清风竹- 发表于 2024-7-18 08:23
最关键的条件没有提供。总分多少是优秀、良好 …… ; 单科多少分是优秀、良好……

总分
语数英120，物70，道历60，化生地历体50
各率为总分的百分数如下
优秀＝〉0.8，良好＝〉0.7，及格＝〉0.6，低分<=0.3,各科0分及缺考不计入参考人数，总分0分及缺考不计入参考人数

清风竹-

清茶一 发表于 2024-7-18 09:28
总分
语数英120，物70，道历60，化生地历体50
各率为总分的百分数如下

总得分的优秀、良好……等。如何计算。是所有科都是优秀，总得分才算优秀吗？

grf1973

平均分得分率，什么意思

清风竹-

grf1973 发表于 2024-7-18 09:57
平均分得分率，什么意思

我猜一下，是超过等于平均分人数除以总人数。

grf1973

平均得分率不知规则，请自行添加。。。。
除了标红的要求外基本都实现了。

清茶一

grf1973 发表于 2024-7-18 14:42
平均得分率不知规则，请自行添加。。。。
除了标红的要求外基本都实现了。

平均分率是个人总分/所有参与科目的总分

grf1973

加进去了。。。。。

3190496160

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