利用VBA宏删除文档中的试题来源

从网上下载的讲义资料往往带有试题来源标记，既占位置，也不重要。如上图的时间地点等内容。统一清理的一般方法是使用通配符查找替换，虽然在单一场景下基本可行，但需要在每个文档中重复手动设置规则，并且由于缺乏预览机制，在全文替换时，用户无法直观看到将被删除的内容，从而增加了误操作风险。

编写 Word 中的 VBA 宏，可以实现自动化处理，避免以上缺点。代码以如下框架构造：

设置方法：打开 Word → 文件 → 选项 → 自定义功能区 → 勾选“开发工具”；按 Alt+F11 打开 VBA 编辑器 → 在左侧选中 Normal → 插入 → 模块 → 粘贴代码；然后添加到自定义功能区：文件 → 选项 → 自定义功能区 → 右侧新建选项卡或新建组 → 左侧下拉选择“宏” → 选中你的宏点击“添加” → 点击“重命名”修改名称和图标 → 确定。再从文件 → 选项 → 信任中心 → 信任中心设置 → 宏设置 → 选择“启用所有宏”。即可在功能区直接点击使用。正确设置后运行，需要删除的题目来源信息会显示在通知窗口。信息过多时会分页显示，逐一确认后将执行删除。

Sub DeleteSource()    Dim doc As Document    Set doc = ActiveDocument    '====================================    ' 统一预处理：将手动换行替换为段落标记    '====================================    With doc.Content.Find        .Text = "^l"        .Replacement.Text = "^p"        .Execute Replace:=wdReplaceAll    End With    '===============    ' 设置正则表达式    '===============    Dim reg As Object    Set reg = CreateObject("VBScript.RegExp")    ' 匹配规则：左括号-四位或两位年份-其它内容-右括号    reg.pattern = "[（(](\d{4}|\d{2}-\d{2})[^(（]*?[）)]"    reg.Global = False    '==========================    ' 设置删除范围与预览显示集合    '==========================    Dim delRanges As Collection    Set delRanges = New Collection    Dim pages As Collection    Set pages = New Collection    Dim currentPage As String    Dim lineCount As Long    currentPage = ""    lineCount = 0    '=============    ' 遍历段落匹配    '=============    Dim para As Paragraph    Dim matches As Object, match As Object    For Each para In doc.Paragraphs        ' 先判断是否可能匹配        Set matches = reg.Execute(para.Range.Text)        If matches.Count > 0 Then            Set match = matches(0)                ' 过滤条件跳过“多选”            If InStr(match.Value, "多选") = 0 Then                ' 记录预览内容                currentPage = currentPage & match.Value & vbCrLf                lineCount = lineCount + 1                If lineCount Mod 30 = 0 Then                    pages.Add currentPage                    currentPage = ""                End If                ' 记录删除范围                delRanges.Add Array( _                    para.Range.Start + match.FirstIndex, _                    para.Range.Start + match.FirstIndex + match.Length _                )            End If        End If    Next para    ' 添加剩下的预览内容到最后一个预览页    If currentPage <> "" Then        pages.Add currentPage    End If    '================    ' 没有预览文本直接退出    '================    If lineCount > 0 Then        '=========        ' 预览阶段        '=========        ' - 未确认则不进入删除逻辑        If Not PreviewPage(pages, lineCount) Then            Exit Sub        End If        '=========        ' 执行删除        '=========        ' 把所有删除合并成 1 步        Application.UndoRecord.StartCustomRecord "Delete Source"        Dim i As Long        ' 倒序删除，防止前面删除影响后面索引        For i = delRanges.Count To 1 Step -1            doc.Range( _                delRanges(i)(0), _                delRanges(i)(1) _            ).Delete        Next i        ' 之后可以 1 次 ctrl+z 全部撤消        Application.UndoRecord.EndCustomRecord    End IfEnd SubFunction PreviewPage(pages As Collection, totalCount As Long) As Boolean    '===================    ' 分页参数, 分页循环    '===================    Dim startLine As Long    Dim endLine As Long    Dim i As Long    For i = 1 To pages.Count        startLine = (i - 1) * 30 + 1        endLine = i * 30        If endLine > totalCount Then endLine = totalCount        If MsgBox( _                "将删除内容共 " & totalCount & " 条" & vbCrLf & _                "当前显示：第 " & startLine & _                " 条 - 第 " & endLine & " 条" & vbCrLf & _                String(45, "-") & vbCrLf & _                pages(i) & _                String(45, "-") & vbCrLf & _                "是否确认？", _                vbYesNo + vbQuestion, "预览") = vbNo Then            PreviewPage = False            Exit Function        End If    Next i    ' 全部确认通过    PreviewPage = TrueEnd Function