20181013xlVba计算优秀率及合格率

Sub 计算高一优秀合格率()
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim dOs As Object 'OutStanding
    Const SUBJECTS = "语文数学英语物理化学生物政治历史地理"
    Set dOs = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("年级_本次成绩总表")

    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
        For j = 4 To EndCol
            If InStr(SUBJECTS, .Cells(1, j).Text) > 0 Then
                Subject = .Cells(1, j).Text
                For i = 2 To EndRow
                    If .Cells(i, "Y").Value = "" Then
                    goal = .Cells(i, j).Value
                    Cls = .Cells(i, 3).Value
                    Key = Cls & ";" & Subject
                    If goal <> "" Then
                        If Not dOs.exists(Key) Then
                            If goal >= OsLine(Subject, 1) Then
                                os = 1
                            Else
                                os = 0
                            End If
                            If goal >= OsLine(Subject, 2) Then
                                pass = 1
                            Else
                                pass = 0
                            End If
                            dOs(Key) = Array(1, os, pass)
                        Else
                            Ar = dOs(Key)
                            Ar(0) = Ar(0) + 1
                            If goal >= OsLine(Subject, 1) Then Ar(1) = Ar(1) + 1
                            If goal >= OsLine(Subject, 2) Then Ar(2) = Ar(2) + 1
                            dOs(Key) = Ar
                        End If
                    End If
                    End If
                Next i
            End If
        Next j
    End With

    'For Each OneKey In dOs.keys
        'Ar = dOs(OneKey)
        'Debug.Print OneKey; "  "; Ar(0); " "; Ar(1); "  "; Ar(2)
    'Next

    Set Sht = Wb.Worksheets("年级_各科离均率")
    With Sht
        StartRow = 60
        ClassCount = 20
        SubjectCount = 10
        .Cells(StartRow + 1, 2).Resize(ClassCount, SubjectCount).ClearContents
        For j = 2 To SubjectCount + 1
            Subject = .Cells(StartRow, j).Value
            For i = StartRow + 1 To StartRow + 20
                Cls = .Cells(i, 1).Value
                Key = Cls & ";" & Subject
                If dOs.exists(Key) Then
                    Ar = dOs(Key)
                    .Cells(i, j).Value = Format(Ar(1) / Ar(0), "0.0%")
                End If
            Next i
        Next j

        StartRow = 84
        ClassCount = 20
        SubjectCount = 10
        .Cells(StartRow + 1, 2).Resize(ClassCount, SubjectCount).ClearContents
        For j = 2 To SubjectCount + 1
            Subject = .Cells(StartRow, j).Value
            For i = StartRow + 1 To StartRow + 20
                Cls = .Cells(i, 1).Value
                Key = Cls & ";" & Subject
                If dOs.exists(Key) Then
                    Ar = dOs(Key)
                    .Cells(i, j).Value = Format(Ar(2) / Ar(0), "0.0%")
                End If
            Next i
        Next j

    End With

End Sub
Function OsLine(ByVal Subject As String, ByVal Level As Long) As Double 'Level 1优秀0合格
    Select Case Subject
    Case "语文", "数学", "英语"
        If Level = 1 Then
            OsLine = 120
        Else
            OsLine = 90
        End If
    Case Else
        If Level = 1 Then
            OsLine = 80
        Else
            OsLine = 60
        End If
    End Select
End Function