体育测试评分

hjd528

“测试结果”表是根据褚老师的代码修改的（https://club.excelhome.net/thread-1680066-1-1.html），基本能实现评分功能，但数据粘贴比较麻烦，因此就改了一下表格，见“调整后”表。调整了表格之后，代码不会修改了。请各位高手帮个忙。


我的需求：
1. 用VBA计算出各项目得分和等级
2. 表中的体重指标和长跑加分数据需要通过计算得出，能否用VBA得出
3. 有三个评分标准，因为标准不一样，放在三个表中，能否放在一个表中
4. 统计表用VBA得出
5.一次性得出结果或分步得出都行


体育测试评分表.rar (272.71 KB, 下载次数: 15)

2023-12-24 10:08 上传

点击文件名下载附件

hjd528

各位大佬，帮忙解决。谢谢。

xsy我可以很好

体育测试成绩自动评分
https://club.excelhome.net/thread-1627313-1-1.html
(出处: ExcelHome技术论坛)

liulang0808

https://club.excelhome.net/forum ... ead&tid=1680066
看看是否可以参考下

chxw68

加分及后面的计算没有看明白。

hjd528

chxw68 发表于 2023-12-25 09:52
加分及后面的计算没有看明白。

感谢褚老师。加分说明下图，附件中也有说明。现在的需求就是：①首先计算出三个值：通过身高和体重计算出体重指数，计算长跑成绩与对应的最高成绩的差值，计算引体/仰卧成绩与对应的最高成绩的差值；②将各项成绩对比标准得出评分和等级；③将各项评分和相应的权重得出总成绩和等级；④最后进行统计


体育测试评分表(含加分说明).rar (288.5 KB, 下载次数: 4)

2023-12-25 19:04 上传

点击文件名下载附件

hjd528

liulang0808 发表于 2023-12-25 07:21
https://club.excelhome.net/forum.php?mod=viewthread&tid=1680066
看看是否可以参考下

谢谢，就是参考这个帖子。但需求有所变化。

hjd528

xsy我可以很好 发表于 2023-12-25 03:05
体育测试成绩自动评分
https://club.excelhome.net/thread-1627313-1-1.html
(出处: ExcelHome技术论坛)
...

谢谢。看过该贴，但我无法修改成我的需求。

chxw68

1. Sub test5()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Dim reg As New RegExp
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Application.ScreenUpdating = False
   
8.     Application.DisplayAlerts = False
   
9.     With reg
   
10.         .Global = False
    
11.         .Pattern = "(\d+)′(\d+)"
    
12.     End With
    
13. 
    
14.     For Each ws In Worksheets(Array("评分标准", "加分标准", "体重标准"))
    
15.         Set d(ws.Name) = CreateObject("scripting.dictionary")
    
16.         With ws
    
17.             r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.             c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
19.             brr = .Range("a1").Resize(r, c)
    
20.             d(ws.Name)(1) = brr
    
21.             For j = 4 To UBound(brr, 2)
    
22.                 If Len(brr(1, j)) <> 0 Then
    
23.                     dx = brr(1, j)
    
24.                 End If
    
25.                 If Len(brr(2, j)) <> 0 Then
    
26.                     xm = brr(2, j)
    
27.                 End If
    
28.                 If Len(brr(3, j)) <> 0 Then
    
29.                     nj = brr(3, j)
    
30.                 End If
    
31.                 xx = nj & "+" & xm & "+" & brr(4, j)
    
32.                 d(ws.Name)(xx) = Array(j, dx)
    
33.             Next
    
34.         End With
    
35.     Next
    
36. 
    
37. 
    
38.     With Worksheets("调整后")
    
39.         .AutoFilterMode = False
    
40.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
41.         .Range("h2:h" & r).ClearContents
    
42.         .Range("o2:aj" & r).ClearContents
    
43.         
    
44.         arr = .Range("a1:aj" & r)
    
45. 
    
46.         brr = d("评分标准")(1)
    
47.         For i = 2 To UBound(arr)
    
48.             arr(i, 8) = Application.Round(arr(i, 7) / (arr(i, 6) / 100) ^ 2, 1)
    
49.             sj1 = 0
    
50.             sj2 = 0
    
51.             Set mh = reg.Execute(arr(i, 13))
    
52.             If mh.Count > 0 Then
    
53.                 sj1 = Val(mh(0).SubMatches(0)) * 60 + Val(mh(0).SubMatches(1))
    
54.             End If
    
55.             xx = arr(i, 2) & "+长跑+" & arr(i, 5)
    
56.             If d("评分标准").exists(xx) Then
    
57.                 crr = d("评分标准")(xx)
    
58.                 Set mh = reg.Execute(brr(5, crr(0)))
    
59.                 If mh.Count > 0 Then
    
60.                     sj2 = Val(mh(0).SubMatches(0)) * 60 + Val(mh(0).SubMatches(1))
    
61.                 End If
    
62.                 If sj2 > sj1 Then
    
63.                     arr(i, 29) = sj2 - sj1
    
64.                 End If
    
65.             End If
    
66.             arr(i, 31) = arr(i, 14)
    
67.         Next
    
68. 
    
69.         For j = 9 To 14
    
70.             For i = 2 To UBound(arr)
    
71.                 xx = arr(i, 2) & "+" & arr(1, j) & "+" & arr(i, 5)
    
72.                 If d("评分标准").exists(xx) Then
    
73.                     crr = d("评分标准")(xx)
    
74.                     If crr(1) = "大" Then
    
75.                         For k = 5 To UBound(brr)
    
76.                             If arr(i, j) >= brr(k, crr(0)) Then
    
77.                                 arr(i, j * 2 - 1) = brr(k, 3)
    
78.                                 Exit For
    
79.                             End If
    
80.                         Next
    
81.                     Else
    
82.                         For k = 5 To UBound(brr)
    
83.                             If arr(i, j) <= brr(k, crr(0)) Then
    
84.                                 arr(i, j * 2 - 1) = brr(k, 3)
    
85.                                 Exit For
    
86.                             End If
    
87.                         Next
    
88.                     End If
    
89.                 End If
    
90.             Next
    
91.         Next
    
92.         brr = d("体重标准")(1)
    
93.         For i = 2 To UBound(arr)
    
94.             xx = arr(i, 2) & "+体重指数+" & arr(i, 5)
    
95.             If d("体重标准").exists(xx) Then
    
96.                 crr = d("体重标准")(xx)
    
97.                 For k = 5 To UBound(brr)
    
98.                     If arr(i, 8) >= brr(k, crr(0)) Then
    
99.                         arr(i, 15) = brr(k, 3)
    
100.                         Exit For
     
101.                     End If
     
102.                 Next
     
103.             End If
     
104.         Next
     
105. 
     
106.         brr = d("加分标准")(1)
     
107.         For j = 29 To 31 Step 2
     
108.             For i = 2 To UBound(arr)
     
109.                 If Len(arr(i, j)) <> 0 And arr(i, j) <> 0 Then
     
110.                     xx = arr(i, 2) & "+" & arr(1, j) & "+" & arr(i, 5)
     
111.                     If d("加分标准").exists(xx) Then
     
112.                         crr = d("加分标准")(xx)
     
113.                         For k = 5 To UBound(brr)
     
114.                             If arr(i, j) >= brr(k, crr(0)) Then
     
115.                                 arr(i, j + 1) = brr(k, 3)
     
116.                                 Exit For
     
117.                             End If
     
118.                         Next
     
119.                     End If
     
120.                 End If
     
121.             Next
     
122.         Next
     
123. 
     
124.     End With
     
125. 
     
126.     For i = 2 To UBound(arr)
     
127.         arr(i, 33) = arr(i, 15) * 0.15 + arr(i, 17) * 0.15 + arr(i, 19) * 0.2 + arr(i, 21) * 0.1 + arr(i, 23) * 0.1 + arr(i, 25) * 0.2 + arr(i, 27) * 0.1
     
128.         arr(i, 34) = arr(i, 30) + arr(i, 32)
     
129.         arr(i, 35) = arr(i, 33) + arr(i, 34)
     
130.         For Each y In Array(15, 17, 19, 21, 23, 25, 27, 35)
     
131.             Select Case arr(i, y)
     
132.                 Case Is >= 90
     
133.                     arr(i, y + 1) = "优秀"
     
134.                 Case Is >= 80
     
135.                     arr(i, y + 1) = "良好"
     
136.                 Case Is >= 60
     
137.                     arr(i, y + 1) = "及格"
     
138.                 Case Else
     
139.                     arr(i, y + 1) = "不及格"
     
140.             End Select
     
141.         Next
     
142.     Next
     
143. 
     
144.     With Worksheets("调整后")
     
145.         .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
     
146.     End With
     
147. End Sub
     

复制代码

chxw68

详见附件。