如何将理(文)综分学科提取的再改进
改进主要集中在标准答案选项的组合提取;各题得分的判断.
①将学生答案进行分列处理:
原效果图:
Sub 分列操作()
Dim i As Integer, totalR As Integer, j As Integer
totalR = Range("A65536").End(xlUp).Row
For i = 2 To totalR
For j = 1 To Len(Cells(i, 4).Value)
Cells(i, 4).Offset(0, j).Value = Mid(Cells(i, 4).Value, j, 1)
Next j
Next i
End Sub
②接下来进行替换操作,将非ABCD字符进行替换:
Sub 替换操作()
Dim i As Integer, totalR As Integer, j As Integer, Rng As Range, totalC As Integer
totalR = Range("A65536").End(xlUp).Row
totalC = Range("IV2").End(xlToLeft).Column
For Each Rng In Range(Cells(2, 5), Cells(totalR, totalC))
Select Case Rng.Value
Case "F"
Rng.Value = "BC"
Case "G"
Rng.Value = "ABC"
Case "H"
Rng.Value = "AB"
Case "I"
Rng.Value = "AD"
Case "J"
Rng.Value = "BD"
Case "K"
Rng.Value = "ABD"
Case "L"
Rng.Value = "CD"
Case "M"
Rng.Value = "ACD"
Case "N"
Rng.Value = "BCD"
Case "O"
Rng.Value = "ABCD"
Case "P"
Rng.Value = "AC"
End Select
Next Rng
End Sub
③提取标准答案的各种组合
Sub 提取标准答案()
Dim i As Integer, j As Integer, k As Integer, totalR As Integer, totalC As Integer
Worksheets("答案").Activate
totalR = Range("A65536").End(xlUp).Row
For i = 2 To totalR
'对于标准答案为2项及单项进行分列操作即可
For j = 1 To Len(Cells(i, 2).Value)
Cells(i, 2).Offset(0, j).Value = Mid(Cells(i, 2).Value, j, 1)
Next j
'对于标准答案为3项的进行组合操作
Select Case Len(Cells(i, 2).Value)
Case 3
Cells(i, Range("IV" & i).End(xlToLeft).Column).Select
For j = 1 To 2
For k = j + 1 To 3
Selection.Offset(0, 1).Value = Mid(Cells(i, 2).Value, j, 1) & Mid(Cells(i, 2).Value, k, 1)
Selection.Offset(0, 1).Select
Next k
Next j
End Select
Next i
End Sub
④判断学生答案对错,并计算分数
Sub 最终定稿()
Dim totalR As Integer, totalC As Integer, i As Integer
Dim MyRng As Range, MyAnswer As Range
Application.DisplayAlerts = False
'删除原来的的得分表,重建新表
Worksheets("客观题得分").Delete
Worksheets("客观题").Copy before:=Sheets(Worksheets.Count)
ActiveSheet.Name = "客观题得分"
'获得得分表的总行数和总列数
totalR = Range("A65536").End(xlUp).Row
totalC = Range("IV1").End(xlToLeft).Column
With Worksheets("答案")
For i = 2 To totalC
For Each MyRng In Range(Cells(2, i), Cells(totalR, i))
'如果学生答案与标准答案完全一样,则为4分,包括1项2项3项情况
If MyRng.Value = .Cells(i, 2).Value Then
MyRng.Value = 4
Else
'判断部分得分及0分的学生答案
Set MyAnswer = .Range(.Cells(i, 3), .Cells(i, .Range("IV" & i).End(xlToLeft).Column))
'统计在组合答案中出现学生答案的次数,只要大于0,就为2分,否则为0分.
If Application.WorksheetFunction.CountIf(MyAnswer, MyRng.Value) > 0 Then
MyRng.Value = 2
Else
MyRng.Value = 0
End If
Set MyAnswer = Nothing
End If
Set MyRng = Nothing '及时释放对象,提高运行速度
Next MyRng
Next i
End With
Application.DisplayAlerts = True
End Sub
BuzzNet： Excel, Excel VBA, VBA, 爱好者, 程序设计, 工作表, 关键字, 应用程序
del.icio.us： Excel, Excel VBA, VBA, 爱好者, 程序设计, 工作表, 关键字, 应用程序
Flickr： Excel, Excel VBA, VBA, 爱好者, 程序设计, 工作表, 关键字, 应用程序
IceRocket： Excel, Excel VBA, VBA, 爱好者, 程序设计, 工作表, 关键字, 应用程序
LiveJournal： Excel, Excel VBA, VBA, 爱好者, 程序设计, 工作表, 关键字, 应用程序
Technorati： Excel, Excel VBA, VBA, 爱好者, 程序设计, 工作表, 关键字, 应用程序
这就是菊子曰啦！