如何根据参数表中各学科等级比例分按班级按年级两种类型将分数变等级

yzyyyyyyy

grf1973 发表于 2014-5-8 13:36
请看附件。按班级的有空再说了。道理一样的，多加几个判断、循环而已。

感谢大师的热心帮助。期待按班级的

mjzxlmg

如何根据参数表中各学科等级比例分按班级按年级两种类型将分数变等级.rar (81.97 KB, 下载次数: 35)

2014-5-9 08:10 上传

点击文件名下载附件

yzyyyyyyy

mjzxlmg 发表于 2014-5-9 08:10

感谢大师的热心帮助，解决了一大难题。能否分数转化为等级的同时，填写相应统计表 如何根据参数表中各学科等级比例分按班级按年级两种类型将分数变等级加统计表.rar (81.88 KB, 下载次数: 8)

2014-5-9 10:58 上传

点击文件名下载附件

grf1973

1. Sub 按班级排序法()
   
2.     Dim N
   
3.     Dim Rng As Range
   
4.     r = [c65536].End(3).Row
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     With Sheet3
   
8.         .Activate
   
9.         .UsedRange.ClearContents
   
10.         Columns("a:L").Copy .[a1]
    
11.         For i = 2 To r
    
12.             .Cells(i, "M") = i - 1
    
13.         Next
    
14.         .Range("a2:M" & r).Sort key1:=.Cells(2, 1), order1:=xlAscending, key2:=.Cells(2, 13), order2:=xlAscending   '按班级排序
    
15.         arr = .[a1].CurrentRegion
    
16.         For i = 2 To UBound(arr)  '按班级排序后，以班级最末行为item
    
17.             d(arr(i, 1)) = i
    
18.         Next
    
19.         dk = d.keys: dt = d.items
    
20.         For j = 4 To 12
    
21.             sr = 2   '每个班级首行
    
22.             If j <> 7 And j <> 8 Then '物理、化学无数据
    
23.                 For i = 0 To UBound(dt)
    
24.                     er = dt(i)  '每个班级末行
    
25.                     Set Rng = .Range("a" & sr & ":M" & er)
    
26.                     N = er - sr + 1 '班级总人数
    
27.                     yx = Round(N * 0.3, 0)   '按比例优秀人数
    
28.                     lh = Round(N * 0.4, 0)   '按比例良好人数
    
29.                     hg = N - yx - lh    '按比例合格人数
    
30.                     Rng.Sort key1:=.Cells(2, j), order1:=xlDescending
    
31.                     .Cells(sr, j).Resize(yx, 1) = "优秀"
    
32.                     .Cells(sr + yx, j).Resize(lh, 1) = "良好"
    
33.                     .Cells(sr + yx + lh, j).Resize(hg, 1) = "合格"
    
34.                     sr = er + 1   '下一班级首行
    
35.                 Next
    
36.             End If
    
37.         Next
    
38.         .Range("a2:M" & r).Sort key1:=.Cells(2, 1), order1:=xlAscending, key2:=.Cells(2, 13), order2:=xlAscending
    
39.         .Range("m:m").Clear
    
40.     End With
    
41.     Application.ScreenUpdating = True
    
42. End Sub

复制代码

grf1973

请看附件。

grf1973

换个思路也行

1. Sub 按班级RANK法()
   
2.     Dim N
   
3.     Dim Rng As Range
   
4.     r = [c65536].End(3).Row
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     Application.ScreenUpdating = False
   
8.     With Sheet3
   
9.         .Activate
   
10.         .UsedRange.ClearContents
    
11.         Columns("a:L").Copy .[a1]
    
12.         .Range("a2:M" & r).Sort key1:=.Cells(2, 1), order1:=xlAscending, key2:=.Cells(2, 13), order2:=xlAscending   '按班级排序
    
13.         arr = .[a1].CurrentRegion
    
14.         For i = 2 To UBound(arr)  '按班级排序后，以班级最末行为item
    
15.             If Not d.exists(arr(i, 1)) Then d(arr(i, 1)) = i   '首行
    
16.             d1(arr(i, 1)) = i   '末行
    
17.         Next
    
18.         For j = 4 To 12
    
19.             If j <> 7 And j <> 8 Then '物理、化学无数据
    
20.                 For i = 2 To UBound(arr)
    
21.                     sr = d(arr(i, 1)) '每个班级首行
    
22.                     er = d1(arr(i, 1)) '每个班级末行
    
23.                     N = er - sr + 1 '班级总人数
    
24.                     Set Rng = .Cells(sr, j).Resize(N, 1)
    
25.                     yx = Round(N * 0.3, 0)   '按比例优秀人数
    
26.                     lh = Round(N * 0.4, 0)   '按比例良好人数
    
27.                     hg = N - yx - lh    '按比例合格人数
    
28.                     xrank = Application.WorksheetFunction.Rank(arr(i, j), Rng) '名次
    
29.                     If xrank <= yx And xyx < yx Then          '如果名次为优秀，总优秀人数小于按比例优秀人数
    
30.                         arr(i, j) = "优秀"
    
31.                         xyx = xyx + 1
    
32.                         '如果名次为优秀，总优秀人数等于按比例优秀人数，或者名次为良好，总良好人数小于按比例良好人数
    
33.                     ElseIf (xrank <= yx And xyx = yx) Or (xrank <= yx + lh And xlh < lh) Then
    
34.                         arr(i, j) = "良好"
    
35.                         xlh = xlh + 1
    
36.                     Else
    
37.                         arr(i, j) = "合格"
    
38.                     End If
    
39.                     If xyx = yx Then xyx = 0
    
40.                     If xlh = lh Then xlh = 0
    
41.                 Next
    
42.             End If
    
43.         Next
    
44.         .[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
45.     End With
    
46.     Application.ScreenUpdating = True
    
47. End Sub

复制代码

mjzxlmg

yzyyyyyyy 发表于 2014-5-9 10:01
感谢大师的热心帮助，解决了一大难题。能否分数转化为等级的同时，填写相应统计表

“能否分数转化为等级的同时，填写相应统计表”
不知是什么意思，请做模拟附件

mjzxlmg

yzyyyyyyy 发表于 2014-5-9 10:01
感谢大师的热心帮助，解决了一大难题。能否分数转化为等级的同时，填写相应统计表

如何根据参数表中各学科等级比例分按班级按年级两种类型将分数变等级.rar (50.47 KB, 下载次数: 20)

2014-5-9 22:52 上传

点击文件名下载附件

mjzxlmg

yzyyyyyyy 发表于 2014-5-9 10:01
感谢大师的热心帮助，解决了一大难题。能否分数转化为等级的同时，填写相应统计表

对代码作了一些优化，提高运行速度。
如何根据参数表中各学科等级比例分按班级按年级两种类型将分数变等级.rar (78.11 KB, 下载次数: 22)

2014-5-12 10:28 上传

点击文件名下载附件

mjzxlmg

yzyyyyyyy 发表于 2014-5-9 10:01
感谢大师的热心帮助，解决了一大难题。能否分数转化为等级的同时，填写相应统计表

添加C列合计列：

如何根据参数表中各学科等级比例分按班级按年级两种类型将分数变等级.rar (79.11 KB, 下载次数: 41)

2014-5-14 11:14 上传

点击文件名下载附件