|
- Option Explicit
- Const ratio_a# = 15 / 100
- Const ratio_b# = 50 / 100
- Const ratio_c# = 85 / 100
- Const ratio_d# = 98 / 100
- Sub 成绩赋等级()
- Dim lastRow%, i%, j%, arr, subjects$(), subject
- Dim fields As Object, schools As Object
-
- Set fields = CreateObject("scripting.dictionary")
- Set schools = CreateObject("scripting.dictionary")
- With Sheets("原始成绩")
- lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:h" & lastRow)
-
- For i = 2 To UBound(arr)
- If Not schools.exists(arr(i, 1)) Then
- Set schools(arr(i, 1)) = New Collection
- schools(arr(i, 1)).Add i
- Else
- schools(arr(i, 1)).Add i
- End If
- Next
-
- For j = 1 To UBound(arr, 2)
- fields(arr(1, j)) = j
- Next
- End With
-
- subjects = Split("语文|数学|英语|生物", "|")
- For Each subject In subjects
- Call 单科赋等级(arr, fields, subject, schools)
- Next
-
- With Sheets("成绩等级(效果)")
- .[a2].CurrentRegion.ClearContents
- .[a2].Resize(UBound(arr), UBound(arr, 2)) = arr
- End With
- MsgBox "完毕!"
- End Sub
- Sub 单科赋等级(ByRef arr, ByRef fields As Object, ByVal subject, ByRef schools As Object)
- Dim num_a%, num_b%, num_c%, num_d%, aList As Object, school, i%, score
-
- Set aList = CreateObject("system.collections.arraylist")
- For Each school In schools.keys
- For i = 1 To schools(school).Count
- score = arr(schools(school)(i), fields(subject))
- If score <> "缺考" Then aList.Add score
- Next
- aList.Sort
- aList.Reverse
- num_a = Round(aList.Count * ratio_a)
- num_b = Round(aList.Count * ratio_b)
- num_c = Round(aList.Count * ratio_c)
- num_d = Round(aList.Count * ratio_d)
- For i = 1 To schools(school).Count
- score = arr(schools(school)(i), fields(subject))
- If score <> "缺考" Then
- Select Case score
- Case Is >= aList(num_a - 1): arr(schools(school)(i), fields(subject)) = "A"
- Case Is >= aList(num_b - 1): arr(schools(school)(i), fields(subject)) = "B"
- Case Is >= aList(num_c - 1): arr(schools(school)(i), fields(subject)) = "C"
- Case Is >= aList(num_d - 1): arr(schools(school)(i), fields(subject)) = "D"
- Case Else: arr(schools(school)(i), fields(subject)) = "E"
- End Select
- End If
- Next
- aList.Clear
- Next
- Set aList = Nothing
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|