|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
这两天没事,闲着,就写了将一套试卷的卷后答案分别移置于对应题号后的代码,供有兴趣的参考使用。
1.试卷后的答案和试题必须用特定分隔符分隔,这在代码中看得出来。
2.试题答案的对应题号比较讲究,必须是“数字”和“.”,这在代码中也看得出来。
如果还有好的代码,欢迎指正。
Sub New卷后答案到题后答案() '本卷后答案由卷后移至题后代友由四川绵竹中学王泽完成,使用请指明出处。
Dim KeyLabelParagraph As Integer '即标志性的答案分隔字符“{【参考答案】}”所在行的行数
Dim KeystartP As Integer
Dim KeyendP As Integer
Dim tempInsertP As Integer
Dim InsertP As Integer
Dim KTRange As Range
Dim i As Integer
Dim n As Integer
Dim m As Integer
ActiveWindow.Selection.HomeKey Unit:=wdStory
With ActiveDocument.ActiveWindow.Selection.Find
.Text = "{【参考答案】}"
End With
ActiveDocument.ActiveWindow.Selection.Find.Execute
If ActiveDocument.ActiveWindow.Selection.Find.Found = False Then
MsgBox "没有找到标志性的答案分隔字符:" & """" & "{【参考答案】}" & """" & ",请设置后再试。", vbInformation, "注意:"
Exit Sub
End If
KeyLabelParagraph = ActiveDocument.Range(0, Selection.End).Paragraphs.Count
KeyendP = KeyLabelParagraph
For i = 1 To KeyLabelParagraph - 1
If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then n = n + 1
Next
For i = KeyLabelParagraph To ActiveDocument.Paragraphs.Count
If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then m = m + 1
Next
If m <> n Then
MsgBox "试题数不等于答案数,检查后再执行。", vbInformation, "注意:"
Exit Sub
End If
ActiveDocument.Application.ScreenUpdating = False
tempInsertP = 0
InsertP = 1
Do
FindKeyStartParagraph:
If InsertP >= KeyLabelParagraph Then Exit Do
For i = KeyendP + 1 To ActiveDocument.Paragraphs.Count
If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then
KeystartP = ActiveDocument.Range(0, ActiveDocument.Paragraphs(i).Range.End).Paragraphs.Count
For n = KeystartP + 1 To ActiveDocument.Paragraphs.Count
If n = ActiveDocument.Paragraphs.Count Then
KeyendP = ActiveDocument.Paragraphs.Count - 1
GoTo FindKeyEndParagraph
ElseIf IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then
KeyendP = n - 1
GoTo FindKeyEndParagraph
End If
Next
FindKeyEndParagraph:
If KeystartP = ActiveDocument.Paragraphs.Count Then
KeyendP = KeystartP
End If
Set KTRange = ActiveDocument.Range(ActiveDocument.Paragraphs(KeystartP).Range.Start, ActiveDocument.Paragraphs(KeyendP).Range.End - 1)
KTRange.Select
ActiveWindow.Selection.Range.Copy
Exit For
End If
Next
FindPosition:
For i = InsertP To KeyLabelParagraph - 1
If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then
If i = KeyLabelParagraph - 1 Then
InsertP = i
Exit For
End If
For m = i + 1 To KeyLabelParagraph - 1
If IsExist(ActiveDocument.Paragraphs(m).Range.Text, "(^\d{1,2}[.])") Then
InsertP = m - 1
GoTo nextFindPosition
ElseIf IsExist(ActiveDocument.Paragraphs(m).Range.Text, "^([二三四五]、|第[ⅡⅢⅣ]卷)") Then
If tempInsertP = 0 Then tempInsertP = m - 1
End If
Next
ElseIf i = KeyLabelParagraph - 1 Then
InsertP = i
End If
Next
nextFindPosition:
If tempInsertP = 0 Then
ActiveDocument.Range(ActiveDocument.Range.Paragraphs(InsertP).Range.End - 1, ActiveDocument.Range.Paragraphs(InsertP).Range.End - 1).Select
Else
ActiveDocument.Range(ActiveDocument.Range.Paragraphs(tempInsertP).Range.End - 1, ActiveDocument.Range.Paragraphs(tempInsertP).Range.End - 1).Select
End If
tempInsertP = 0
ActiveWindow.Selection.TypeText (vbCrLf & "【答案】:")
TimeLapse (0.7) '可根据自己的机器性能对该值进行调整,值越大时间延越长,值越小时间延时越短,时间不合理过短会导致程序出错!
ActiveWindow.Selection.Range.Paste
InsertP = InsertP + KTRange.Paragraphs.Count + 1
KeyLabelParagraph = KeyLabelParagraph + KTRange.Paragraphs.Count
KeyendP = KeyendP + 1
If KeyendP = KeyLabelParagraph Then Exit Do
Loop
ActiveWindow.Selection.HomeKey Unit:=wdStory
With ActiveDocument.ActiveWindow.Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.Execute FindText:="^p^p", ReplaceWith:="^p", Replace:=wdReplaceAll
End With
ActiveWindow.Selection.EndKey Unit:=wdStory
ActiveWindow.Selection.MoveLeft Unit:=wdCharacter, Count:=1
With ActiveDocument.ActiveWindow.Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.Execute FindText:="^p^p", ReplaceWith:=" ", Replace:=wdReplaceOne
End With
With ActiveDocument.Content.Find '删除“【答案】:”后的数字
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
With .Replacement '替换条件
.ClearFormatting
End With
.Execute FindText:="([【][答][案][】][:])([0-9]{1,2}.)(*)", ReplaceWith:="\1\3", Replace:=wdReplaceAll '屏蔽上行,答案中对应的题号将会显示出来。
End With
ActiveWindow.Selection.HomeKey Unit:=wdStory
MsgBox "程序执行完成。", vbInformation, "注意:"
ActiveDocument.Application.ScreenUpdating = True
End Sub
Public Function IsExist(ByVal sText As String, ByVal Regul As String) As Boolean
Dim reg
Set reg = CreateObject("vbscript.regexp")
IsExist = False
With reg
.Global = True
.IgnoreCase = False
.Pattern = Regul '识别试题题号的关键,根据你的需要可以进行增删
If .test(sText) Then
IsExist = True
End If
End With
End Function
Private Sub TimeLapse(ByVal a As Byte)
Dim Savetime As Single
Savetime = Timer '记下开始的时间
While Timer < Savetime + a '循环等待
DoEvents '转让控制权,以便让操作系统处理其它的事件
Wend
End Sub
最后祝大家春节快乐。祝管理员给我发个大红包。 |
|