学生成绩按年级人数比例赋等级

hbszls

yynrzwh 发表于 2024-5-5 18:58
一个学校就一个年级？你也没有年级列

多年级会更复杂呀。感谢你们的支持！

yynrzwh

你的要求是按年级人数比例判断等级，
现在年级都确定不了。

baofa2

1. Option Explicit
   
2. 
   
3. 'https://club.excelhome.net/thread-1691405-1-1.html
   
4. 
   
5. Sub test1() '纯个人练习，可以分校分年级处理，但没有年级信息，这里当作同一年级
   
6.   
   
7.   Dim data, per, num() As Long
   
8.   Dim i As Long, j As Long, x As Long, y As Long
   
9.   Dim cnt As Long, pos As Long, col As Long, sum_ As Long
   
10.   
    
11.   per = Application.Rept(Worksheets("分值表").Range("B8:F8").Value, 1)
    
12.   ReDim num(LBound(per) To UBound(per))
    
13.   
    
14.   data = Worksheets("原始成绩").Range("A1").CurrentRegion.Offset(1).Value
    
15.   ReDim Preserve data(1 To UBound(data), 1 To UBound(data, 2) + 1)
    
16.   
    
17.   col = 2
    
18.   For j = 4 To UBound(data, 2) - 1
    
19.     col = col + 1
    
20.     For i = 1 To UBound(data) - 1
    
21.       data(i, col) = Replace(data(i, j), "缺考", "")
    
22.     Next
    
23.   Next
    
24.   col = col + 2
    
25.   data(1, col - 1) = "总分"
    
26.   For i = 2 To UBound(data) - 1
    
27.     data(i, col - 1) = ""
    
28.     data(i, col) = UBound(data) - i   '最后一列写入降序序号，便于后面排序恢复原来顺序
    
29.   Next
    
30.   
    
31.   QuickSort data, 2, UBound(data) - 1, 1, col, 1, False  '按校排序，若有序则不用
    
32.   For j = 4 To col - 2
    
33.     pos = 1
    
34.     For i = pos + 1 To UBound(data) - 1
    
35.       If data(i, 1) <> data(i + 1, 1) Then  '判断学校
    
36.         cnt = 0
    
37.         sum_ = 0
    
38.         QuickSort data, pos + 1, i, 1, col, j, True   '同一校内年级成绩降序
    
39.         For y = pos + 1 To i
    
40.           If Len(data(y, j)) Then cnt = cnt + 1 Else Exit For  '计算有成绩人数
    
41.         Next
    
42.         For x = LBound(num) To UBound(num)
    
43.           num(x) = per(x) * cnt     '计算有成绩人数内 各等级 人数，总数可能多也可能少(概率大于多)
    
44.           '用四舍五入 可能导致人数变多，这里四舍六入五单双 也可能导致人数变多，后面有处理
    
45.           sum_ = sum_ + num(x)
    
46.         Next
    
47.         If sum_ < cnt Then num(UBound(num)) = num(UBound(num)) + (cnt - sum_) '可能人数变少时加在最后一个等级中
    
48.         For x = LBound(num) To UBound(num) '按 各等级 人数 写入相应等级
    
49.           For y = pos + 1 To pos + num(x)
    
50.             data(y, j) = Chr(x + 64)
    
51.             data(y, col - 1) = data(y, col - 1) & Chr(x + 64)
    
52.             pos = pos + 1
    
53.             cnt = cnt - 1
    
54.             If cnt = 0 Then Exit For '处理可能 人数多于有效成绩数
    
55.           Next
    
56.         Next
    
57.         pos = i
    
58.       End If
    
59.     Next
    
60.   Next
    
61.   
    
62.   QuickSort data, 2, UBound(data) - 1, 1, col, col, True  '按写入的序号降序排序，恢复原来顺序
    
63.   With Worksheets("成绩等级（效果）").Range("A2")
    
64.     .CurrentRegion.Offset(1).Clear 'Contents
    
65.     With .Resize(UBound(data) - 1, col - 1)
    
66.       .Borders.LineStyle = xlContinuous
    
67.       .HorizontalAlignment = xlCenter
    
68.       .Font.Name = "宋体"
    
69.       .Font.Size = 10
    
70.       .Value = data
    
71.     End With
    
72.   End With
    
73.   
    
74.   Beep
    
75. End Sub
    
76. 
    
77. Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pCol As Long, Optional Flag As Boolean = True)
    
78.   Dim t As Long, b As Long, x As Long, pivot, swap
    
79.   t = u
    
80.   b = d
    
81.   pivot = ar((u + d) \ 2, pCol)
    
82.   While t <= b
    
83.     If Flag Then        'Order by number Descending
    
84.       Do
    
85.         If ar(t, pCol) > pivot Then t = t + 1 Else Exit Do
    
86.       Loop While t < d
    
87.       Do
    
88.         If ar(b, pCol) < pivot Then b = b - 1 Else Exit Do
    
89.       Loop While b > u
    
90.     Else                'Order by text Ascending
    
91.       Do
    
92.         If StrComp(ar(t, pCol), pivot, vbTextCompare) = -1 Then t = t + 1 Else Exit Do
    
93.       Loop While t < d  'vbTextCompare 1  vbBinaryCompare 0
    
94.       Do
    
95.         If StrComp(pivot, ar(b, pCol), vbTextCompare) = -1 Then b = b - 1 Else Exit Do
    
96.       Loop While b > u
    
97.     End If
    
98.     If t < b Then
    
99.       For x = l To r
    
100.         swap = ar(t, x): ar(t, x) = ar(b, x): ar(b, x) = swap
     
101.       Next
     
102.       t = t + 1: b = b - 1
     
103.     Else
     
104.       If t = b Then t = t + 1: b = b - 1
     
105.     End If
     
106.   Wend
     
107.   If t < d Then QuickSort ar, t, d, l, r, pCol, Flag
     
108.   If b > u Then QuickSort ar, u, b, l, r, pCol, Flag
     
109. End Function

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr(), crr()
   
4.     Dim rng As Range
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     With Worksheets("分值表")
   
8.         Set rng = .Columns(1).Find(what:="等级", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious)
   
9.         fz = rng.Offset(0, 1).Resize(3, 5)
   
10.     End With
    
11.     For j = 2 To UBound(fz, 2)
    
12.         fz(2, j) = fz(2, j) + fz(2, j - 1)
    
13.     Next
    
14.     With Worksheets("原始成绩")
    
15.         .AutoFilterMode = False
    
16.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
17.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
18.         arr = .Range("a3").Resize(r - 2, c)
    
19.     End With
    
20.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
21.     For i = 1 To UBound(arr)
    
22.         brr(i, 1) = arr(i, 1)
    
23.         brr(i, 2) = arr(i, 2)
    
24.         brr(i, 3) = arr(i, 4)
    
25.     Next
    
26.     For j = 5 To UBound(arr, 2)
    
27.         m = 0
    
28.         For i = 1 To UBound(arr)
    
29.             If IsNumeric(arr(i, j)) Then
    
30.                 m = m + 1
    
31.                 ReDim Preserve crr(1 To m)
    
32.                 crr(m) = arr(i, j)
    
33.             End If
    
34.         Next
    
35.         If m > 0 Then
    
36.             For k = 1 To UBound(fz, 2)
    
37.                 fz(3, k) = Application.Round(Application.Large(crr, UBound(crr) * fz(2, k)), 2)
    
38.             Next
    
39.         End If
    
40.         For i = 1 To UBound(arr)
    
41.             If IsNumeric(arr(i, j)) Then
    
42.                 For q = 1 To UBound(fz, 2)
    
43.                     If arr(i, j) >= fz(3, q) Then
    
44.                         brr(i, j - 1) = fz(1, q)
    
45.                         brr(i, 8) = brr(i, 8) & brr(i, j - 1)
    
46.                         Exit For
    
47.                     End If
    
48.                 Next
    
49.             End If
    
50.         Next
    
51.     Next
    
52.     With Worksheets("成绩等级（效果）")
    
53.         .UsedRange.Offset(2, 0).Clear
    
54.         .Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
55.     End With
    
56. End Sub
    

复制代码

chxw68

参与一下。

hbszls

chxw68 发表于 2024-5-7 09:06
参与一下。

太感谢了，昨天看到了你几年前回复的一个帖子，麻烦有时间的时候能否看看，名次分布改为各科的，谢谢！
https://club.excelhome.net/thread-1584527-1-1.html

chxw68

hbszls 发表于 2024-5-7 09:37
太感谢了，昨天看到了你几年前回复的一个帖子，麻烦有时间的时候能否看看，名次分布改为各科的，谢谢！
...

模拟结果传上来。

hbszls

chxw68 发表于 2024-5-7 09:43
模拟结果传上来。

这是你前几年回复的一个帖子，以前是以总分做的名次分布，现在想改为各科目的名次分布。谢谢！

chxw68

修改好了。

hbszls

chxw68 发表于 2024-5-7 11:46
修改好了。

谢谢，很好！