如何将理(文)综分学科提取
问题提出:由于阅卡机的原因,导致无法提取单科成绩,这个程序就是解决这个问题.
代码如下:
(1)取得标准选项的各种组合
需要准备的数据:题号及标准选项,C列及后续列为程序生成.
Sub 取得标准选项的各种组合()
Dim totalR As Integer, i As Integer
Worksheets("答案").Activate
totalR = Range("A65536").End(xlUp).Row
For i = 2 To totalR
Select Case Len(Cells(i, 2).Value)
Case 3
With Cells(i, 2)
.Offset(0, 1).Value = Mid(.Value, 1)
.Offset(0, 2).Value = Mid(.Value, 1, 1)
.Offset(0, 3).Value = Mid(.Value, 2, 1)
.Offset(0, 4).Value = Mid(.Value, 3, 1)
.Offset(0, 5).Value = Mid(.Value, 1, 1) & Mid(.Value, 2, 1)
.Offset(0, 6).Value = Mid(.Value, 1, 1) & Mid(.Value, 3, 1)
.Offset(0, 7).Value = Mid(.Value, 2, 1) & Mid(.Value, 3, 1)
End With
Case 2
With Cells(i, 2)
.Offset(0, 1).Value = Mid(.Value, 1)
.Offset(0, 2).Value = Mid(.Value, 1, 1)
.Offset(0, 3).Value = Mid(.Value, 2, 1)
End With
Case 1
With Cells(i, 2)
.Offset(0, 1).Value = Mid(.Value, 1)
End With
End Select
Next i
End Sub
(2)将原始客观题的各题选项进行分列处理
原效果图:
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
(3)接下来进行替换操作,将非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
(4)计算客观题的得分
Sub 客观题得分()
Dim Rng As Range, totalR As Integer, totalC As Integer, i As Integer, j As Integer, m As Integer, cuwu As String
With Worksheets("客观题")
.Activate
totalR = Range("A65536").End(xlUp).Row
totalC = Range("IV2").End(xlToLeft).Column
Debug.Print totalC
Worksheets("答案").Activate
For i = 2 To totalR
For j = 2 To totalC
If Len(.Cells(i, j).Value) = 0 Then
.Cells(i, j).Value = 0
Else
Select Case Len(Range("C" & j).Value)
Case 1
Set Rng = Range("C" & j)
If .Cells(i, j).Value = Rng.Value Then
.Cells(i, j).Value = 4
Else
.Cells(i, j).Value = 0
End If
Case 2
Debug.Print Range("C" & j).Value
If .Cells(i, j).Value = Cells(j, 3).Value Then
.Cells(i, j).Value = 4
Else
If .Cells(i, j).Value = Cells(j, 4).Value Then
.Cells(i, j).Value = 2
Else
If .Cells(i, j).Value = Cells(j, 5).Value Then
.Cells(i, j).Value = 2
Else
.Cells(i, j).Value = 0
End If
End If
End If
Case 3
For m = 1 To 4
If InStr(Range("C" & j).Value, Chr(m + 64)) = 0 Then
cuwu = Chr(m + 64)
End If
Next m
If InStr(.Cells(i, j).Value, cuwu) > 0 Then
.Cells(i, j).Value = 0
Else
If .Cells(i, j).Value = Cells(j, 3).Value Then
.Cells(i, j).Value = 4
Else
For m = 1 To 6
If .Cells(i, j).Value = Cells(j, m + 3).Value Then
.Cells(i, j).Value = 2
End If
Next m
End If
End If
End Select
End If
Next j
Next i
.Activate
End With
End Sub
BuzzNet： Excel, Excel VBA, Range, VBA, 爱好者, 工作表, 关键字, 循环, 应用程序, 元素, 源程序, 子程序, 字典, 字符串, 最大值
del.icio.us： Excel, Excel VBA, Range, VBA, 爱好者, 工作表, 关键字, 循环, 应用程序, 元素, 源程序, 子程序, 字典, 字符串, 最大值
Flickr： Excel, Excel VBA, Range, VBA, 爱好者, 工作表, 关键字, 循环, 应用程序, 元素, 源程序, 子程序, 字典, 字符串, 最大值
IceRocket： Excel, Excel VBA, Range, VBA, 爱好者, 工作表, 关键字, 循环, 应用程序, 元素, 源程序, 子程序, 字典, 字符串, 最大值
LiveJournal： Excel, Excel VBA, Range, VBA, 爱好者, 工作表, 关键字, 循环, 应用程序, 元素, 源程序, 子程序, 字典, 字符串, 最大值
Technorati： Excel, Excel VBA, Range, VBA, 爱好者, 工作表, 关键字, 循环, 应用程序, 元素, 源程序, 子程序, 字典, 字符串, 最大值
本文用菊子曰发布