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

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.   Set d_da = CreateObject("scripting.dictionary")
   
10.   With reg
    
11.     .Pattern = "^(\d+)\.题"
    
12.   End With
    
13.   
    
14.   With Worksheets("设置")
    
15.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
16.     arr = .Range("a3:d4")
    
17.     ReDim cs(1 To 4)
    
18.     cs(1) = .Columns(arr(1, 2)).Column
    
19.     cs(2) = .Columns(arr(1, 4)).Column
    
20.     cs(3) = .Columns(arr(2, 2)).Column
    
21.     cs(4) = .Columns(arr(2, 4)).Column
    
22.     arr = .Range("a5:e" & r)
    
23.     For i = 2 To UBound(arr)
    
24.       Set d_da(arr(i, 1)) = CreateObject("scripting.dictionary")
    
25.       For j = 2 To UBound(arr, 2)
    
26.         d_da(arr(i, 1))(arr(1, j)) = arr(i, j)
    
27.       Next
    
28.     Next
    
29.     zf = Application.Sum(Application.Index(arr, 0, 3))
    
30.   End With
    
31.   
    
32.   
    
33.   With Worksheets("源作业")
    
34.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
35.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
36.     arr = .Range("a1").Resize(r, c)
    
37.     ReDim brr(1 To UBound(arr) + 2, 1 To 3 + d_da.Count)
    
38.     ls = UBound(brr, 2)
    
39.     brr(1, 1) = "题号"
    
40.     brr(1, ls - 1) = "总分"
    
41.     brr(1, ls) = "得分率"
    
42.     brr(2, 1) = "标准答案"
    
43.     brr(3, 1) = "平均得分"
    
44.     n = 2
    
45.     For Each aa In d_da.keys
    
46.       brr(1, n) = aa
    
47.       brr(2, n) = d_da(aa)("答案")
    
48.       n = n + 1
    
49.     Next
    
50.    
    
51.     For i = 2 To UBound(arr)
    
52.       brr(i + 2, 1) = arr(i, cs(3))
    
53.       For j = cs(1) To cs(2)
    
54.         If InStr(arr(i, j), ".") <> 0 Then
    
55.           Set mh = reg.Execute(arr(1, j))
    
56.           If mh.Count > 0 Then
    
57.             n = Val(mh(0).SubMatches(0)) + 1
    
58.             brr(i + 2, n) = brr(i + 2, n) & Split(arr(i, j), ".")(1)
    
59.           End If
    
60.         End If
    
61.       Next
    
62.     Next
    
63.   End With
    
64.   
    
65.   For j = 2 To ls - 2
    
66.     For i = 4 To UBound(brr)
    
67.       If Len(brr(i, j)) <> 0 Then
    
68.         If Len(brr(2, j)) = 1 Then
    
69.           If brr(i, j) = brr(2, j) Then
    
70.             brr(i, j) = d_da(brr(1, j))("全对得分") & "|" & brr(i, j)
    
71.           Else
    
72.             brr(i, j) = d_da(brr(1, j))("错选得分") & "|" & brr(i, j)
    
73.           End If
    
74.         Else
    
75.           If Len(brr(i, j)) = Len(brr(2, j)) Then
    
76.             If brr(i, j) = brr(2, j) Then
    
77.               brr(i, j) = d_da(brr(1, j))("全对得分") & "|" & brr(i, j)
    
78.             Else
    
79.               brr(i, j) = d_da(brr(1, j))("错选得分") & "|" & brr(i, j)
    
80.             End If
    
81.           ElseIf Len(brr(i, j)) > Len(brr(2, j)) Then
    
82.             brr(i, j) = d_da(brr(1, j))("错选得分") & "|" & brr(i, j)
    
83.           Else
    
84.             flg = True
    
85.             For k = 1 To Len(brr(i, j))
    
86.               ch = Mid(brr(i, j), k, 1)
    
87.               If InStr(brr(2, j), ch) = 0 Then
    
88.                 flg = False
    
89.                 Exit For
    
90.               End If
    
91.             Next
    
92.             If flg Then
    
93.               brr(i, j) = d_da(brr(1, j))("漏选得分") & "|" & brr(i, j)
    
94.             Else
    
95.               brr(i, j) = d_da(brr(1, j))("错选得分") & "|" & brr(i, j)
    
96.             End If
    
97.           End If
    
98.         End If
    
99.       End If
    
100.     Next
     
101.   Next
     
102.   
     
103.   For i = 4 To UBound(brr)
     
104.     For j = 2 To ls - 2
     
105.       brr(i, ls - 1) = brr(i, ls - 1) + Val(brr(i, j))
     
106.     Next
     
107.     brr(i, ls) = Round(brr(i, ls - 1) / zf, 4)
     
108.   Next
     
109.   
     
110.   For j = 2 To ls - 1
     
111.     For i = 4 To UBound(brr)
     
112.       brr(3, j) = brr(3, j) + Val(brr(i, j))
     
113.     Next
     
114.   Next
     
115.   For j = 2 To ls - 1
     
116.     brr(3, j) = Round(brr(3, j) / (UBound(brr) - 3), 2)
     
117.   Next
     
118.   brr(3, ls) = Round(brr(3, ls - 1) / zf, 4)
     
119.   With Worksheets("评分")
     
120.     .UsedRange.Offset(1, 0).ClearContents
     
121.     .Columns(UBound(brr, 2)).NumberFormatLocal = "0.00%"
     
122.     .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
     
123.     With .Range("a2").Resize(UBound(brr), UBound(brr, 2))
     
124.       .Borders.LineStyle = xlContinuous
     
125.     End With
     
126.     With .UsedRange
     
127.       .HorizontalAlignment = xlCenter
     
128.       .VerticalAlignment = xlCenter
     
129.     End With
     
130.   End With
     
131. End Sub

复制代码

chxw68

修改好了。

chxw68

完善了一下。

chxw68

感觉参数设置表里的一些参数设置是画蛇添足，取消掉由代码自动判断还是要好一些。

yus99

chxw68 发表于 2020-3-3 16:58
感觉参数设置表里的一些参数设置是画蛇添足，取消掉由代码自动判断还是要好一些。

非常感谢，刚才发的样表，评分 表中 B列少 一列 班级。不能能帮助完善一下。谢谢。
另外，因为其他老师要问我，这是谁做的，怎么介绍您呢？能不能私下告知下。

chxw68

修改好了。

yus99

chxw68 发表于 2020-3-3 17:38
修改好了。

非常感谢！根据代码，我想修改一下，如果得满分不显色，漏选显示浅一点颜色填充，错选深一点颜色填充。
修改好久没有实现。能不能再帮帮。都不好意思开口了。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim flg As Boolean
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   Set d1 = CreateObject("scripting.dictionary")
   
10.   
    
11.   With Worksheets("设置")
    
12.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
13.     arr = .Range("a3:e" & r)
    
14.     ksmc = .Range("b1")
    
15.     For i = 2 To UBound(arr)
    
16.       Set d1(arr(i, 1)) = CreateObject("scripting.dictionary")
    
17.       For j = 2 To UBound(arr, 2)
    
18.         d1(arr(i, 1))(arr(1, j)) = arr(i, j)
    
19.       Next
    
20.     Next
    
21.     zf = Application.Sum(Application.Index(arr, 0, 3))
    
22.   End With
    
23.   
    
24.   ls = d1.Count + 4
    
25.   With Worksheets("源作业")
    
26.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
27.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
28.     arr = .Range("a1").Resize(r, c)
    
29.     j0 = -1
    
30.     j1 = -1
    
31.     For j = 1 To UBound(arr, 2)
    
32.       If InStr(arr(1, j), "姓名") <> 0 Then
    
33.         j0 = j
    
34.       ElseIf InStr(arr(1, j), "班级") <> 0 Then
    
35.         j1 = j
    
36.       End If
    
37.     Next
    
38.     If j0 = -1 Then
    
39.       MsgBox "源作业表格数据有误！"
    
40.       Exit Sub
    
41.     End If
    
42.       
    
43.     ReDim brr(1 To UBound(arr) + 2, 1 To ls)
    
44.     ReDim crr(1 To UBound(arr) + 2, 1 To ls)
    
45.     brr(1, 1) = "姓名"
    
46.     brr(1, 2) = "班级"
    
47.     brr(1, ls - 1) = "总分"
    
48.     brr(1, ls) = "得分率"
    
49.     n = 3
    
50.     For Each aa In d1.keys
    
51.       brr(1, n) = aa
    
52.       brr(2, n) = d1(aa)("答案")
    
53.       n = n + 1
    
54.     Next
    
55.    
    
56.     For i = 2 To UBound(arr)
    
57.       brr(i + 2, 1) = arr(i, j0)
    
58.       If j1 <> -1 Then
    
59.         brr(i + 2, 2) = arr(i, j1)
    
60.       End If
    
61.       For j = 1 To UBound(arr, 2)
    
62.         If InStr(arr(i, j), ".") <> 0 Then
    
63.           n = Val(Split(arr(1, j), ".")(0))
    
64.           If d1.exists(n) Then
    
65.             brr(i + 2, n + 2) = brr(i + 2, n + 2) & Split(arr(i, j), ".")(1)
    
66.           End If
    
67.         End If
    
68.       Next
    
69.     Next
    
70.   End With
    
71.   
    
72.   For j = 3 To ls - 2
    
73.     For i = 4 To UBound(brr)
    
74.       If Len(brr(i, j)) <> 0 Then
    
75.         If Len(brr(i, j)) = Len(brr(2, j)) Then
    
76.           If brr(i, j) = brr(2, j) Then
    
77.             brr(i, j) = d1(brr(1, j))("全对得分") & "|" & brr(i, j)
    
78.             crr(i, j) = 1
    
79.           Else
    
80.             brr(i, j) = d1(brr(1, j))("错选得分") & "|" & brr(i, j)
    
81.             crr(i, j) = -1
    
82.           End If
    
83.         ElseIf Len(brr(i, j)) > Len(brr(2, j)) Then
    
84.           brr(i, j) = d1(brr(1, j))("错选得分") & "|" & brr(i, j)
    
85.           crr(i, j) = -1
    
86.         Else
    
87.           flg = True
    
88.           For k = 1 To Len(brr(i, j))
    
89.             ch = Mid(brr(i, j), k, 1)
    
90.             If InStr(brr(2, j), ch) = 0 Then
    
91.               flg = False
    
92.               Exit For
    
93.             End If
    
94.           Next
    
95.           If flg Then
    
96.             brr(i, j) = d1(brr(1, j))("漏选得分") & "|" & brr(i, j)
    
97.             crr(i, j) = 0
    
98.           Else
    
99.             brr(i, j) = d1(brr(1, j))("错选得分") & "|" & brr(i, j)
    
100.             crr(i, j) = -1
     
101.           End If
     
102.         End If
     
103.       End If
     
104.     Next
     
105.   Next
     
106. 
     
107.   For i = 4 To UBound(brr)
     
108.     For j = 3 To ls - 2
     
109.       brr(i, ls - 1) = brr(i, ls - 1) + Val(brr(i, j))
     
110.     Next
     
111.     brr(i, ls) = Round(brr(i, ls - 1) / zf, 4)
     
112.   Next
     
113. 
     
114.   For j = 3 To ls - 1
     
115.     For i = 4 To UBound(brr)
     
116.       brr(3, j) = brr(3, j) + Val(brr(i, j))
     
117.     Next
     
118.   Next
     
119.   For j = 3 To ls - 1
     
120.     brr(3, j) = Round(brr(3, j) / (UBound(brr) - 3), 2)
     
121.   Next
     
122.   brr(3, ls) = Round(brr(3, ls - 1) / zf, 4)
     
123.   With Worksheets("评分")
     
124.     .Cells.Clear
     
125.     With .Range("a1")
     
126.       .Value = ksmc
     
127.       .Resize(1, ls).Merge
     
128.       With .Font
     
129.         .Name = "微软雅黑"
     
130.         .Size = 16
     
131.       End With
     
132.     End With
     
133.     .Columns(UBound(brr, 2)).NumberFormatLocal = "0.00%"
     
134.     .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
     
135.     .Range("c2").Resize(1, ls - 4).NumberFormatLocal = "0题"
     
136.     For i = 4 To UBound(crr)
     
137.       For j = 3 To ls - 2
     
138.         If Len(crr(i, j)) <> 0 Then
     
139.           Select Case crr(i, j)
     
140.             Case 1
     
141.               .Cells(i + 1, j).Interior.ColorIndex = 4
     
142.             Case 0
     
143.               .Cells(i + 1, j).Interior.ColorIndex = 6
     
144.             Case -1
     
145.               .Cells(i + 1, j).Interior.ColorIndex = 3
     
146.           End Select
     
147.         End If
     
148.       Next
     
149.     Next
     
150.     For j = 1 To 2
     
151.       .Cells(2, j).Resize(3, 1).Merge
     
152.     Next
     
153.     For j = ls - 1 To ls
     
154.       .Cells(2, j).Resize(2, 1).Merge
     
155.     Next
     
156.     With .Range("a2").Resize(UBound(brr), UBound(brr, 2))
     
157.       .Borders.LineStyle = xlContinuous
     
158.     End With
     
159.     With .UsedRange
     
160.       .HorizontalAlignment = xlCenter
     
161.       .VerticalAlignment = xlCenter
     
162.     End With
     
163.   End With
     
164.   Application.ScreenUpdating = True
     
165.   MsgBox "成绩统计完毕！"
     
166. End Sub

复制代码

chxw68

修改好了！全对-绿，半对-黄，错-红。