|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
又重新给楼主研究了好久，有些成果，请楼主认真阅读一下宏的注释部分：（限于水平和时间，仅作抛砖引玉）
Sub test()
'功能：答案填入试卷（请备份原文件后应用此宏！！！）
'myRange=答案 key，myRange2=试题 ask（域对域，在域 Range 中查找答案和放入答案）
'请手工将《答案部分》剪切另存为 key.doc，《试题部分》另存为 ask.doc，两者放在同一文件夹中
'Sub 全文预处理()
With ActiveDocument.Content.Find
.Execute FindText:="^l", replacewith:="^p", Replace:=wdReplaceAll '手动换行符=>段落标记（全部替换）
.Execute FindText:="^13", replacewith:="^p", Replace:=wdReplaceAll '真假回车符=>段落标记（全部替换）
.Execute FindText:="(", replacewith:="（", Replace:=wdReplaceAll
.Execute FindText:=")", replacewith:="）", Replace:=wdReplaceAll
End With
On Error Resume Next
Dim i As Paragraph, s As String, n As Long, myRange As Range, myRange2 As Range
'******************************************************第一大题：答案提取和填入（单项选择题）
'答案部分：选定第一大题
Windows("key").Activate
For Each i In ActiveDocument.Paragraphs
If i.Range Like "一、*" & vbCr Then i.Range.Select
Next
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Loop Until Right(Selection, 2) = "二、"
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Set myRange = Selection.Range
'试题部分：选定第一大题
Windows("ask").Activate
For Each i In ActiveDocument.Paragraphs
If i.Range Like "一、*" & vbCr Then i.Range.Select
Next
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Loop Until Right(Selection, 2) = "二、"
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Set myRange2 = Selection.Range
n = 1
'进入循环
Do
Windows("key").Activate '*****答案部分
myRange.Select
Selection.Find.Execute FindText:=n & "、", Forward:=True, Wrap:=wdFindStop
If Selection.Find.Found = True Then
Selection.Font.Color = wdColorPink
Selection.Next(Unit:=wdParagraph, Count:=1).Select '选定当前选定内容的下一段落
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
s = Right(Selection, 1)
End If
'
Windows("ask").Activate '****试题部分
myRange2.Select
Selection.Find.Execute FindText:=n & "、", Forward:=True, Wrap:=wdFindStop
If Selection.Find.Found = True Then
Selection.Paragraphs(1).Range.Select
Selection.Find.Execute FindText:="（", Forward:=True, Wrap:=wdFindStop
If Selection.Find.Found = True Then
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Characters.Last.Text = "）" Then Exit Do
Loop
Selection.Font.Color = wdColorRed
Selection.Text = "（" & s & "）"
End If
n = n + 1
Else
Exit Do
End If
Loop
'*************************第二大题：答案提取和填入（多项选择---在第一大题代码基础上略改！）********************
'答案部分：选定第二大题
Windows("key").Activate
For Each i In ActiveDocument.Paragraphs
If i.Range Like "二、*" & vbCr Then i.Range.Select
Next
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Loop Until Right(Selection, 2) = "三、"
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Set myRange = Selection.Range
'试题部分：选定第二大题
Windows("ask").Activate
For Each i In ActiveDocument.Paragraphs
If i.Range Like "二、*" & vbCr Then i.Range.Select
Next
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Loop Until Right(Selection, 2) = "三、"
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Set myRange2 = Selection.Range
n = 1
'进入循环
Do
Windows("key").Activate '*****答案部分
myRange.Select
Selection.Find.Execute FindText:=n & "、", Forward:=True, Wrap:=wdFindStop
If Selection.Find.Found = True Then
Selection.Font.Color = wdColorPink
Selection.Next(Unit:=wdParagraph, Count:=1).Select
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
s = Trim(Mid(Selection, 7, Len(Selection) - 6))
End If
'
Windows("ask").Activate '****试题部分
myRange2.Select
Selection.Find.Execute FindText:=n & "、", Forward:=True, Wrap:=wdFindStop
If Selection.Find.Found = True Then
Selection.Paragraphs(1).Range.Select
Selection.Find.Execute FindText:="（", Forward:=True, Wrap:=wdFindStop
If Selection.Find.Found = True Then
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Characters.Last.Text = "）" Then Exit Do
Loop
Selection.Font.Color = wdColorRed
Selection.Text = "（" & s & "）"
End If
n = n + 1
Else
Exit Do
End If
Loop
'********************************第三大题：答案提取和填入（略）*************************
Selection.HomeKey Unit:=wdStory
MsgBox "处理完毕！！！！！！！！！！！！", vbOKOnly + vbExclamation, "答案填入试卷"
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-5-6 13:48
楼主
