如何根据EXCEL回收答案进行评分

gbgbxgb

试试附件。
练习打分.rar (24.72 KB, 下载次数: 3)

2020-2-28 14:27 上传

点击文件名下载附件

chxw68

我又仔细看了一遍，应该能够自适应题目数量。如果楼主还有问题，建议上传出错文件。

yus99

micch 发表于 2020-2-27 22:11
源表那么多列，是不是很多是不用的？结果表空的列，是不需要计算的吗？？

您好，源表中 有些数据是没有用的，但是导出就这样，就没有动表格

yus99

chxw68 发表于 2020-2-28 14:48
我又仔细看了一遍，应该能够自适应题目数量。如果楼主还有问题，建议上传出错文件。

非常感谢，的确可以。我以为评分页面是自动生成的，把题号删除了。如果增平均分和得分率，能不能麻烦处理一下？谢谢。！

chxw68

yus99 发表于 2020-2-28 15:49
非常感谢，的确可以。我以为评分页面是自动生成的，把题号删除了。如果增平均分和得分率，能不能麻烦处理 ...

评分页面无法自动生成，因为正确答案就在这个页面里呢。

yus99

增加了每题得分情况和得分率，怎么处理呢？谢谢大家

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, crr, drr()
   
4.   Dim d As Object
   
5.   Dim reg As New RegExp
   
6.   Dim flg As Boolean
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With reg
   
10.     .Pattern = "^(\d+)\.题"
    
11.   End With
    
12.   With Worksheets("源作业")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
15.     arr = .Range("a1").Resize(r, c)
    
16.     For j = 1 To UBound(arr, 2)
    
17.       Set mh = reg.Execute(arr(1, j))
    
18.       If mh.Count > 0 Then
    
19.         th = Val(mh(0).SubMatches(0))
    
20.         d1(j) = th
    
21.       End If
    
22.     Next
    
23.     For i = 2 To UBound(arr)
    
24.       xm = arr(i, UBound(arr, 2))
    
25.       If Not d.exists(xm) Then
    
26.         ReDim brr(1 To th + 3)
    
27.         brr(1) = xm
    
28.       Else
    
29.         brr = d(xm)
    
30.       End If
    
31.       For j = 8 To UBound(arr, 2) - 2
    
32.         If d1.exists(j) Then
    
33.           n = d1(j) + 1
    
34.           If Len(arr(i, j)) <> 0 Then
    
35.             brr(n) = brr(n) & Split(arr(i, j), ".")(1)
    
36.           End If
    
37.         End If
    
38.       Next
    
39.       d(xm) = brr
    
40.     Next
    
41.   End With
    
42.   With Worksheets("评分")
    
43.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
44.     crr = .Range("a1").Resize(1, c)
    
45.   End With
    
46.   brr = Application.Transpose(Application.Transpose(d.items))
    
47.   For j = 2 To UBound(brr, 2) - 2
    
48.     For i = 1 To UBound(brr)
    
49.       If Len(brr(i, j)) <> 0 Then
    
50.         If Len(crr(1, j)) = 1 Then
    
51.           If brr(i, j) = crr(1, j) Then
    
52.             brr(i, j) = "5|" & brr(i, j)
    
53.           Else
    
54.             brr(i, j) = "0|" & brr(i, j)
    
55.           End If
    
56.         Else
    
57.           If Len(brr(i, j)) = Len(crr(1, j)) Then
    
58.             If brr(i, j) = crr(1, j) Then
    
59.               brr(i, j) = "5|" & brr(i, j)
    
60.             Else
    
61.               brr(i, j) = "0|" & brr(i, j)
    
62.             End If
    
63.           ElseIf Len(brr(i, j)) > Len(crr(1, j)) Then
    
64.             brr(i, j) = "0|" & brr(i, j)
    
65.           Else
    
66.             flg = True
    
67.             For k = 1 To Len(brr(i, j))
    
68.               ch = Mid(brr(i, j), k, 1)
    
69.               If InStr(crr(1, j), ch) = 0 Then
    
70.                 flg = False
    
71.                 Exit For
    
72.               End If
    
73.             Next
    
74.             If flg Then
    
75.               brr(i, j) = "2|" & brr(i, j)
    
76.             Else
    
77.               brr(i, j) = "0|" & brr(i, j)
    
78.             End If
    
79.           End If
    
80.         End If
    
81.       End If
    
82.     Next
    
83.   Next
    
84.   For i = 1 To UBound(brr)
    
85.     For j = 2 To UBound(brr, 2) - 2
    
86.       brr(i, UBound(brr, 2) - 1) = brr(i, UBound(brr, 2) - 1) + Val(brr(i, j))
    
87.     Next
    
88.     brr(i, UBound(brr, 2)) = Round(brr(i, UBound(brr, 2) - 1) / (th * 5), 4)
    
89.   Next
    
90.   ReDim drr(1 To UBound(brr, 2))
    
91.   drr(1) = "每题平均分"
    
92.   For j = 2 To UBound(brr, 2) - 1
    
93.     For i = 1 To UBound(brr)
    
94.       drr(j) = drr(j) + Val(brr(i, j))
    
95.     Next
    
96.   Next
    
97.   For j = 2 To UBound(drr) - 1
    
98.     drr(j) = Round(drr(j) / UBound(brr), 2)
    
99.   Next
    
100.   drr(UBound(drr)) = Round(drr(UBound(drr) - 1) / (th * 5), 4)
     
101.   With Worksheets("评分")
     
102.     .UsedRange.Offset(2, 0).ClearContents
     
103.     .Columns(UBound(brr, 2)).NumberFormatLocal = "0.00%"
     
104.     .Range("a3").Resize(1, UBound(drr)) = drr
     
105.     .Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
     
106.     With .Range("a1").Resize(UBound(brr) + 3, UBound(brr, 2))
     
107.       .Borders.LineStyle = xlContinuous
     
108.     End With
     
109.     With .UsedRange
     
110.       .HorizontalAlignment = xlCenter
     
111.       .VerticalAlignment = xlCenter
     
112.     End With
     
113.   End With
     
114. End Sub
     
115. 
     
116. 
     

复制代码

chxw68

详见附件。

yus99

非常感谢！完美至极！谢谢！解决了我好多天的困扰啊！

yus99

chxw68 发表于 2020-2-28 16:07
详见附件。

非感谢，老师们看到我用后，有些科目老师也想用，但是由于学科分值不同，处理就很麻烦，加了设置，如果这样处理能就可以其他科也可以解决了。谢谢。