根据缺考学生的各科成绩平均排名确定此学生各科缺考成绩

sunshuangzhong

说明：
要求实现功能：根据缺考学生的各科成绩平均排名确定此学生各科缺考成绩

成绩为0表示缺考

举例1：如果某学生语文缺考第三次，计算该生前二次语文的平均排名（四舍五入），根据这个排名在第三次语文成绩找出对应的语文成绩用于该生此次的语文成绩
举例2：如果某学生语文缺考第一次，计算该生后二次语文的平均排名（四舍五入），根据这个排名在第1次语文成绩找出对应的语文成绩用于该生此次的语文成绩
举例3：如果某学生语文缺考第一次和第三次，计算该生第二次语文的排名，根据这个排名分别在第1.3次语文成绩找出对应的语文成绩用于该生此2次的语文成绩

主要用于缺考学生分班用，给他缺考的学科一个相对合理的成绩。

谢谢！

戎马书生222

你这样，还不如求出各学科的平均成绩，更容易实现。

sunshuangzhong

原来用的是平均成绩，领导说不合理，用平均名次决定缺考成绩。老大说了算。现实分班中也只是个别优秀缺考学生有用。大部分缺考学生都是按0分处理了。

3190496160

这种问题，代码不难写，但是，关键是代码的计算量太大，速度就是问题

micch

缺考第一次，缺考第二次，缺考第三次，缺考第12次，缺考第23次，缺考第13次，缺考123次...........................

yynrzwh

戎马书生222

如果3次考试，只考了1次，随机性更大。这种赋分更没公平性可言。和取平均分差不多。

戎马书生222

根据语文，模拟了一次。自己修改一下吧。排名是从论坛大侠：chx68，学习而来的。感谢

1. Sub pm()
   
2.     Dim arr, targetCols(), resultCols(), j As Integer, i As Long
   
3.     Dim d As Object, fs_sz, fs, cnt As Long, mc As Long
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     arr = Sheet1.[a1].CurrentRegion.Value
   
7.     targetCols = Array(3, 4, 5) '需排名的列（如第2、3列）
   
8.     resultCols = Array(6, 7, 8) '结果写入列（如第3、4列）
   
9.       For j = LBound(targetCols) To UBound(targetCols)
   
10.         d.RemoveAll
    
11.         '统计频率
    
12.         For i = 2 To UBound(arr)
    
13.             If arr(i, targetCols(j)) <> "" Then
    
14.             d(arr(i, targetCols(j))) = ""
    
15.             End If
    
16.         Next
    
17.         fs_sz = d.keys
    
18.         '计算排名
    
19.         For i = 0 To UBound(fs_sz)
    
20.             fs = WorksheetFunction.Large(fs_sz, i + 1)
    
21.             d2(arr(1, targetCols(j)) & i + 1) = fs
    
22.             d(fs) = i + 1
    
23.         Next
    
24.         '写入结果列
    
25.         For i = 2 To UBound(arr)
    
26.             arr(i, resultCols(j)) = d(arr(i, targetCols(j)))
    
27.         Next
    
28.     Next j
    
29.     '开始操作了
    
30.    Set d = Nothing
    
31.    Set d = CreateObject("scripting.dictionary")
    
32.     For i = 2 To UBound(arr)
    
33.         n = 0
    
34.         For j = 6 To UBound(arr, 2)
    
35.             n = n + 1
    
36.             If Not d.exists(arr(i, 1)) Then
    
37.             d(arr(i, 1)) = Application.WorksheetFunction.Round(arr(i, j) / n, 0)
    
38.             Else
    
39.             d(arr(i, 1)) = WorksheetFunction.Round((d(arr(i, 1)) + arr(i, j)) / n, 0)
    
40.             End If
    
41.         Next
    
42.     Next
    
43.     For j = 3 To 5
    
44.         For i = 2 To UBound(arr)
    
45.             If arr(i, j) = "" Or arr(i, j) = 0 Then
    
46.                 arr(i, j) = d2(arr(1, j) & d(arr(i, 1)))
    
47.             End If
    
48.         Next
    
49.     Next
    
50. Sheet1.[a1].CurrentRegion = arr
    
51. End Sub
    
52. 
    
53. 
    

复制代码

sunshuangzhong

yynrzwh 发表于 2025-5-10 16:51

完全正确，正是我想要的！高人呀！无论几次成绩都通用！真是一个好代码！

yynrzwh

很高兴能帮到你！