|
|
T 分标准和段数，可自由设置，学科数量，6科 、7科 ...... 只要二表稍作对应的修正，代码只修改一个数字即可！
Sub kscj_to_tjf()
' 2024-8-30
' 名称：考试成绩 转换成 等级分
' 思路：1、计算等级分区间； 2、计算等级分
'
' 重要说明：成绩表上的学科从左到排列顺序与区间标准表上的学科排列顺序要一致，
' 学科可以是6个，也可是7个，二表设置好后，只要修改 变量 KMS 的值即可
'
Sheet2.Activate
Dim Arr, Brr, Crr, M, Lfgs, Zrs, S1, S2, S, T, T1, T2, Kms, Jsh
Kms = 6 ' *******需要划分成绩的学科数。请根据实际学科的数量修改***********
Sheet2.[F6].Resize(20, 14) = ""
Arr = Sheet1.[A1].CurrentRegion ' 原始成绩存入数组 Arr
Jsh = UBound(Arr)
For y = 1 To Kms ' 按选修的课目数循环，即依次处理每一个学科
ReDim Brr(1 To UBound(Arr) - 1, 1 To 2)
Lfgs = 0
For x = 2 To UBound(Arr)
Brr(x - 1, 1) = Arr(x, y + 6) ' 将一个学科的原始成绩写入到Brr中
If Arr(x, y + 6) = 0 Then
Lfgs = Lfgs + 1
End If
Next x
For i = 1 To UBound(Brr)
For j = i To UBound(Brr)
If Brr(i, 1) < Brr(j, 1) Then
temp = Brr(j, 1)
Brr(j, 1) = Brr(i, 1)
Brr(i, 1) = temp
End If
Next j
Next i ' 对一课的成绩完成排序
Zrs = UBound(Brr) - Lfgs ' 成绩不为 0 的人数
x2 = 6
S2 = 200
Do While Not (IsEmpty(Sheet2.Cells(x2, 1).Value))
ReDim Crr(1 To Zrs / 2, 1 To 2)
tjrs = Int(Zrs * Sheet2.Cells(x2, 3).Value + 0.5)
S1 = Brr(tjrs, 1)
Sheet2.Cells(x2, y * 2 + 5).Value = S1 ' 记录某科的S1分值
M = 1
For i = 1 To UBound(Brr)
If Brr(i, 1) < S2 And Brr(i, 1) >= S1 Then
Crr(M, 1) = Brr(i, 1)
M = M + 1
End If
Next i
Sheet2.Cells(x2, y * 2 + 4).Value = Crr(1, 1) ' 记录某科的S2分值
S2 = S1
Erase Crr
Set Crr = Nothing
x2 = x2 + 1
Loop
Erase Brr
Set Brr = Nothing
Next y
Erase Arr
Set Arr = Nothing
Set Brr = Nothing
Set Crr = Nothing
'End Sub
'Sub 计算等级分()
' 2024-8-30
' 计算每个学生的每一个学科的等级分
'
Sheet1.Activate
Range(Cells(2, 7), Cells(Jsh, Kms + 6)).Interior.ColorIndex = xlNone
[M2].Resize(Jsh, Kms + 1) = ""
'Dim kms, T, T1, T2, S, S1, S2
'kms = 6
For y = 1 To Kms
x1 = 2
Do While Not (IsEmpty(Sheet1.Cells(x1, 2).Value))
S = Sheet1.Cells(x1, y + 6).Value
If S = 0 Then
Sheet1.Cells(x1, y + 6).Select
Selection.Interior.ColorIndex = 6
GoTo 99 ' 成绩为 0 ，跳过区间分的比对，并染上背景色
End If
x2 = 6
Do While Not (IsEmpty(Sheet2.Cells(x2, 4).Value))
S2 = Sheet2.Cells(x2, y * 2 + 4).Value
S1 = Sheet2.Cells(x2, y * 2 + 5).Value
T2 = Sheet2.Cells(x2, 4).Value
T1 = Sheet2.Cells(x2, 5).Value
If S >= S1 And S <= S2 Then
If S1 = S2 Then
Sheet1.Cells(x1, y + 6 + Kms).Value = T2
Else
Sheet1.Cells(x1, y + 6 + Kms).Value = Int(((S2 - S) * T1 + (S - S1) * T2) / (S2 - S1) + 0.5)
End If
End If
x2 = x2 + 1
Loop
99 x1 = x1 + 1
Loop
Next y
Range("A1").Select
MsgBox "等级分计算完成 ！"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-31 06:35
但是，出现了赋分不连续的情况，比如99以后应该是对应98，但是出现了99之后是97的情况，类似比较多，如何理解呢？谢谢
楼主
