将学生体育测试成绩评分

hnyeke

现有一份学生体育考试成绩，每个学生测试三项，测试的三项分男女按标准评分。点击“计分”按钮，根据评分标准给每个学生的三项测试成绩计分。

因数据较大且是多次重复的工作，请求高手完善代码。谢谢，详见附件。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6. '    Set reg = CreateObject("vbscript.regexp")
   
7.     With Worksheets("评分标准")
   
8.         r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
9.         brr = .Range("a1:i" & r)
   
10.         For j = 2 To UBound(brr, 2) Step 3
    
11.             d(brr(1, j)) = j
    
12.         Next
    
13.     End With
    
14.     With Worksheets("学生名册")
    
15.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.         arr = .Range("a1:k" & r)
    
17.         For j = 6 To UBound(arr, 2) Step 2
    
18.             If d.exists(arr(1, j)) Then
    
19.                 n1 = d(arr(1, j))
    
20.                 For i = 2 To UBound(arr)
    
21.                     n2 = IIf(arr(i, 5) = "男", 0, 1)
    
22.                     If Len(arr(i, j)) <> 0 Then
    
23.                         For k = 3 To UBound(brr)
    
24.                             If arr(i, j) >= brr(k, n1 + n2) Then
    
25.                                 arr(i, j + 1) = brr(k, n1 - 1)
    
26.                                 Exit For
    
27.                             End If
    
28.                         Next
    
29.                         If k > UBound(brr) Then
    
30.                             arr(i, j + 1) = 0
    
31.                         End If
    
32.                     End If
    
33.                 Next
    
34.             End If
    
35.         Next
    
36.         .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
37.     End With
    
38. End Sub
    

复制代码

chxw68

详见附件。

hnyeke

chxw68 发表于 2023-3-30 18:43
详见附件。

感谢老师的回答，

vvw123

chxw68 发表于 2023-3-30 18:43
详见附件。

优秀作品，做个标记，以备学习