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

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