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

yus99 · 发表于 2020-2-27 19:46

如两个图，源作业表，是原始回收的表格，每次回收情况，单选、不定项选择题号不定。单选题只一列答案，不定项选择有四列答案，想做成评分表的样式。注意打分标准，全对5分，半对2分，错0分。（半对指答案不全，但没有错误选择项。如某题答案为ACD。当选择ACD，5分，选AC、AD、CD、A、C、D，2分，只要有B答案为0分）
麻烦看有没有什么好的解决方法，谢谢各位前辈！

zopey · 发表于 2020-2-27 21:34

简单处理下

练习打分.rar (30.69 KB, 下载次数: 9)

micch · 发表于 2020-2-27 22:11

源表那么多列，是不是很多是不用的？结果表空的列，是不需要计算的吗？？

chxw68 · 发表于 2020-2-27 22:18

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim reg As New RegExp
Dim flg As Boolean
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With reg
.Pattern = "^(\d+)\.题"
End With
With Worksheets("源作业")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
For j = 1 To UBound(arr, 2)
Set mh = reg.Execute(arr(1, j))
If mh.Count > 0 Then
th = Val(mh(0).SubMatches(0))
d1(j) = th
End If
Next
With Worksheets("源作业")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For i = 2 To UBound(arr)
xm = arr(i, UBound(arr, 2))
If Not d.exists(xm) Then
ReDim brr(1 To th + 2)
brr(1) = xm
Else
brr = d(xm)
End If
For j = 8 To UBound(arr, 2) - 2
If d1.exists(j) Then
n = d1(j) + 1
If Len(arr(i, j)) <> 0 Then
brr(n) = brr(n) & Split(arr(i, j), ".")(1)
End If
End If
Next
d(xm) = brr
Next
End With
With Worksheets("评分")
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
crr = .Range("a1").Resize(1, c)
End With
brr = Application.Transpose(Application.Transpose(d.items))
For j = 2 To UBound(brr, 2) - 1
For i = 1 To UBound(brr)
If Len(brr(i, j)) <> 0 Then
If Len(crr(1, j)) = 1 Then
If brr(i, j) = crr(1, j) Then
brr(i, j) = "5|" & brr(i, j)
Else
brr(i, j) = "0|" & brr(i, j)
End If
Else
If Len(brr(i, j)) = Len(crr(1, j)) Then
If brr(i, j) = crr(1, j) Then
brr(i, j) = "5|" & brr(i, j)
Else
brr(i, j) = "0|" & brr(i, j)
End If
ElseIf Len(brr(i, j)) > Len(crr(1, j)) Then
brr(i, j) = "0|" & brr(i, j)
Else
flg = True
For k = 1 To Len(brr(i, j))
ch = Mid(brr(i, j), k, 1)
If InStr(crr(1, j), ch) = 0 Then
flg = False
Exit For
End If
Next
If flg Then
brr(i, j) = "2|" & brr(i, j)
Else
brr(i, j) = "0|" & brr(i, j)
End If
End If
End If
End If
Next
Next
For i = 1 To UBound(brr)
For j = 2 To UBound(brr, 2) - 1
brr(i, UBound(brr, 2)) = brr(i, UBound(brr, 2)) + Val(brr(i, j))
Next
Next
With Worksheets("评分")
.Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2020-2-27 22:19

详见附件。

YZC51 · 发表于 2020-2-27 22:33

本帖最后由 YZC51 于 2020-2-27 22:57 编辑

zopey 发表于 2020-2-27 21:34
简单处理下

学习老师的代码。谢谢老师！
Sub 按钮1_Click()
Dim arr, brr(), k0
arr = Worksheets("源作业").[a1].CurrentRegion
ReDim brr(2 To UBound(arr), 1 To 14)
For j = 1 To UBound(arr, 2)
      temp = InStr(arr(1, j), ".题")
      If temp > 0 Then
         k0 = Val(Left(arr(1, j), temp - 1))
         For i = 2 To UBound(arr)
            brr(i, k0) = brr(i, k0) & Left(arr(i, j), 1)
         Next
      End If
Next
Dim crr
crr = Range("b1").Resize(1, 13)
For i = 2 To UBound(arr)
      For j = 1 To 13
         x1 = dafen(brr(i, j), crr(1, j))
         x = x + x1
         brr(i, j) = x1 & "|" & brr(i, j)
         brr(i, 14) = x
      Next
      x = 0
Next
[b3].Resize(UBound(arr) - 1, 14) = brr
End Sub

Function dafen(x, y)
If x = y Then dafen = 5: Exit Function
If x = "" Then dafen = 0: Exit Function
For i = 1 To Len(x)
      If InStr(y, Mid(x, i, 1)) = 0 Then dafen = 0: Exit Function
Next
dafen = 2
End Function

YZC51 · 发表于 2020-2-27 22:34

本帖最后由 YZC51 于 2020-2-27 22:51 编辑

请参考

练习打分-.rar (31.22 KB, 下载次数: 4)

yus99 · 发表于 2020-2-28 12:07

chxw68 发表于 2020-2-27 22:19
详见附件。

非常感谢，测试成功！只是有时候，我们的练习选择题目数可能有20个，有时30个，刚才测试13个没有问题，但是增加一个选择题后，不能通过。再次深表谢意！

yus99 · 发表于 2020-2-28 12:09

YZC51 发表于 2020-2-27 22:34
请参考

谢谢，测试13个题没有问题，有时会多一些题目，有时会少一些题目，怎么处理呢？谢谢！

yus99 · 发表于 2020-2-28 12:43

刚才，试着修改，不能成功，麻烦能不能加一个参数，设置多少道题目啊？谢谢！

		自动登录	找回密码
密码			免费注册

[求助] 如何根据EXCEL回收答案进行评分

评分

最新热点 /1