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