如何将理(文)综分学科提取的再改进

改进主要集中在标准答案选项的组合提取;各题得分的判断.

①将学生答案进行分列处理:

原效果图:

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

43 Things： Excel, Excel VBA, VBA, 爱好者, 程序设计, 工作表, 关键字, 应用程序
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, 爱好者, 程序设计, 工作表, 关键字, 应用程序

 这就是菊子曰啦！