成绩分数转等级

grf1973

简化代码，把复杂的事情留给字典。

cyq4896

参与一下...

Qs18

参与一下。。。。

沈默00

Enocheasty 发表于 2024-5-10 09:50
其实我就想说，公式都可以决绝的，为啥一定要用VBA。不过大佬们也是很热心。

最近不想写代码，，研究下新函数，，，发现功能也很强大。。。。
殊途同归，达到效果就好，数据量大还是VBA好些，

全党

1. <div class="blockcode"><blockquote>Sub 试试()
   
2.     Dim r%, i%, j%, c%
   
3.     Dim arr, brr
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     brr = Worksheets("参数设置").Range("a1").CurrentRegion
   
6.     r = UBound(brr)
   
7.     For j = 2 To UBound(brr, 2)
   
8.       d(brr(1, j)) = Array(brr(2, j), brr(3, j), brr(4, j), brr(5, j), brr(6, j))
   
9.     Next
   
10.     arr = Worksheets("原始成绩").Range("a1").CurrentRegion
    
11.     For i = 5 To UBound(arr, 2)
    
12.         bzx = d(arr(2, i))
    
13.         For j = 3 To UBound(arr)
    
14.         fs = arr(j, i)
    
15.         Select Case fs
    
16.             Case Is >= bzx(1): arr(j, i) = "优秀"
    
17.             Case Is >= bzx(2): arr(j, i) = "良好"
    
18.             Case Is >= bzx(3): arr(j, i) = "合格"
    
19.          Case Else
    
20.             arr(j, i) = "待合格"
    
21.         End Select
    
22. Next j, i
    
23.     With Worksheets("成绩等级(结果)")
    
24.         .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
25.         .Range("a1").Resize(1, UBound(arr, 2)).Merge
    
26.         .Range("a2").Resize(UBound(arr) - 1, UBound(arr, 2)).Borders.LineStyle = 1
    
27.         .Columns(3).Delete
    
28.     End With
    
29. End Sub

复制代码

hbszls

Qs18 发表于 2024-5-10 13:55
参与一下。。。。

如果有学生某科没有参考，是否可以在等级里填入“缺考”并标色。谢谢！

浦东坡

还是字典加数组的方法最好