Word VBA快速制作试卷(2/2)

实例需求：英语听力题目及其答案（题目编号之前括号内字母为答案）如下所示。

现在需要将文档整理为如下格式：

• 第一部分为听力题目，擅长每个题目编号之前的答案（包含括号）
• 增加一个段落“参考答案”
• 第3部分为听力题目含参考答案，并修改英语如下格式
  – 题目编号之前的答案应用红色字体
  – 题目答案选项应用红色字体和下划线

其效果如下图所示。

Sub Demo()
    Dim oDoc As Document: Set oDoc = ActiveDocument
    Dim oRng As Range: Set oRng = oDoc.Range
    Dim iEnd As Long: iEnd = oRng.End
    oRng.Copy
    oRng.InsertParagraphAfter
    oRng.Paragraphs.Last.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
    oRng.Characters.Last.InsertAfter vbCr & "参考答案" & vbCr
    oRng.Collapse Direction:=wdCollapseEnd
    oRng.Paste
    Dim pasteRange As Range
    Set pasteRange = oRng
    If pasteRange.ListFormat.ListType <> wdListNoNumbering Then
        pasteRange.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:=False
    End If
    Dim oAnswer As Range, sAnswer As String
    With pasteRange.Find
        .ClearFormatting
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = "\( [A-Z] \)"
        Do While .Execute
            With .Parent
                sAnswer = Trim(Mid(.Text, 2, Len(.Text) - 2))
                Set oAnswer = .Paragraphs(1).Next.Range
                .Font.ColorIndex = wdRed
            End With
            With oAnswer.Find
                .ClearFormatting
                .Wrap = wdFindStop
                .MatchWildcards = True
                .Text = sAnswer & "\. <*>\."
                .Replacement.Font.ColorIndex = wdRed
                .Replacement.Font.Underline = wdUnderlineSingle
                .Execute Replace:=wdReplaceAll
            End With
        Loop
    End With
    Set oRng = oDoc.Range(0, iEnd)
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "\( [A-Z] \)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub

【代码解析】
第2行代码获取当前活动文档对象，并赋值给变量 oDoc。
第3行代码获取整个文档的范围Range对象，用于后续内容操作。
第4行代码记录当前文档末尾位置的字符索引，用于后续定位处理前的内容（即原始文档内容）。
第5行代码将整个文档复制到剪贴板。
第6行代码在文档末尾插入一个新的段落，以便后续插入答案内容。
第7行代码移除最后一个段落中可能存在的编号格式，确保复制内容时格式统一。
第8行代码在文档末尾插入段落标记和“参考答案”（作为一个单独段落），用于标识复制内容的开始。
第9行代码将范围折叠到末尾，准备粘贴剪贴板中的内容。
第10行代码将先前复制的内容粘贴到“参考答案”段落之后。
粘贴操作完成之后，oRng对象将代表新粘贴的文档内容，即oRng的范围发生了变化。
第11行代码定义一个新的范围对象 pasteRange，用于表示刚刚粘贴的答案区域。
第12行代码将 pasteRange 设置为粘贴内容。
第13-15行代码判断 pasteRange 是否存在编号，如果存在则重新应用编号样式，使粘贴内容具有统一格式。

第16行代码定义两个变量用于存储当前查找到的答案内容和操作范围。
第21行代码配置查找条件，使用通配符查找模式\( [A-Z] \)，查找形如( A )的选项格式。
第22~37行代码为查找循环，逐个处理答案标记。
第23~27行代码提取选项字母（去除括号），并标红原始答案位置。
第28-36行代码在答案区域查找与选项内容匹配的题干项（如 A. 正确），将其字体颜色设置为红色，并加下划线，标示正确答案。

第39行代码重新设置范围对象 oRng 为从文档开头到原始末尾（iEnd）之前的内容（即不包括新粘贴的“参考答案”及其之后的内容），准备查找操作。
第43~44行代码设置查找条件，并将其替换为空字符串，删除所有题目前的答案选项编号。
第54行执行全部替换。