如何优化Word VBA水印移除宏的大文档遍历效率？

我编写的Word VBA宏用于移除文档中所有水印，逻辑是先删除所有前置环绕的形状，再处理页眉/页脚中与其他文本混合的文本框水印——移除重复出现的水印文本同时保留原有内容。宏功能正常，但在百页以上的大文档中运行需要数分钟。尝试限制检查范围（比如仅检查最后2-3个前置环绕文本框、仅检查页面特定边距的水印）时出现错误。现有宏代码如下：

Sub CompleteRemover()
Dim doc As Document
Dim shp As Shape
Dim shpRange As Range
Dim textDict As Object
Dim pageDict As Object
Dim key As Variant
Dim text As String
Dim pageCollection As Object
Dim shapesToProcess As Collection
Dim shpInfo As Variant
Dim i As Long
Dim pageCount As Long

' Create dictionary objects to store text counts and page occurrences
Set textDict = CreateObject("Scripting.Dictionary")
Set pageDict = CreateObject("Scripting.Dictionary")
Set shapesToProcess = New Collection

' Reference the active document
Set doc = ActiveDocument

' Disable screen updating to improve performance
Application.ScreenUpdating = False

' Get the total number of pages in the document
pageCount = doc.ComputeStatistics(wdStatisticPages)

' Loop through shapes in reverse order to avoid indexing issues when deleting shapes
For i = doc.Shapes.Count To 1 Step -1
    Set shp = doc.Shapes(i)
    On Error Resume Next

    ' Check for watermarks
    If shp.WrapFormat.Type = wdWrapFront Then
        shp.Delete
    End If

    ' Check for text boxes in headers/footers
    If shp.Type = msoTextBox And shp.TextFrame.HasText Then
        Set shpRange = shp.Anchor.Paragraphs(1).Range
        Dim pageIndex As Long
        pageIndex = shpRange.Information(wdActiveEndPageNumber)
        text = Left(shp.TextFrame.textRange.text, 255) ' Limit to 255 characters

        ' Store shape information in a collection
        shapesToProcess.Add Array(shp, text, pageIndex)

        If textDict.Exists(text) Then
            textDict(text) = textDict(text) + 1
            Set pageCollection = pageDict(text)
            If Not pageCollection.Exists(pageIndex) Then
                pageCollection.Add pageIndex, True
            End If
        Else
            textDict.Add text, 1
            Set pageCollection = CreateObject("Scripting.Dictionary")
            pageCollection.Add pageIndex, True
            pageDict.Add text, pageCollection
        End If
    End If
    On Error GoTo 0
Next i

' Second pass: Remove the watermark text from the textboxes with repeating text on every page
For Each key In textDict.Keys
    If pageDict(key).Count = pageCount Then
        For Each shpInfo In shapesToProcess
            Set shp = shpInfo(0)
            text = shpInfo(1)
            If InStr(text, key) > 0 Then
                With shp.TextFrame.textRange.Find
                    .text = key
                    .Replacement.text = ""
                    .Forward = True
                    .Wrap = wdFindStop
                    .Format = True
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=wdReplaceAll
                End With
            End If
        Next shpInfo
    End If
Next key

' Re-enable screen updating
Application.ScreenUpdating = True

' Display completion message
MsgBox "Watermarks Removed."
End Sub

核心优化方案 #

1. 聚焦页眉/页脚，减少无效遍历 #

水印绝大多数存在于页眉/页脚中，直接遍历文档的节、页眉/页脚集合，而非整个文档的所有形状，能大幅削减需要处理的对象数量，避免遍历正文无关形状的开销。

2. 优化页面覆盖统计逻辑 #

原代码逐形状获取页面索引的操作耗时极高，改为统计页眉/页脚覆盖的页面范围，批量更新文本的页面出现记录，避免单形状单页面的重复计算。

3. 拆分功能为辅助过程 #

将页眉/页脚处理、水印文本移除拆分为独立的辅助过程，既提升代码可读性，也避免单次遍历中嵌套过多逻辑导致的性能损耗。

4. 关闭更多后台功能 #

除了关闭屏幕更新，额外关闭自动保存、弹窗提示、打印通信等Word后台功能，进一步降低运行时的资源占用。

优化后的完整代码 #

Sub OptimizedWatermarkRemover()
    Dim doc As Document
    Dim section As section
    Dim headerFooter As HeaderFooter
    Dim shp As Shape
    Dim textDict As Object
    Dim watermarkTexts As Collection
    Dim totalPages As Long
    
    ' 初始化对象
    Set doc = ActiveDocument
    Set textDict = CreateObject("Scripting.Dictionary")
    Set watermarkTexts = New Collection
    
    ' 关闭不必要的功能提升性能
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = wdAlertsNone
        .AutoSaveOn = False
        .PrintCommunication = False
    End With
    
    totalPages = doc.ComputeStatistics(wdStatisticPages)
    
    ' 第一步：删除所有前置环绕的水印形状
    For Each shp In doc.Shapes
        If shp.WrapFormat.Type = wdWrapFront Then
            shp.Delete
        End If
    Next shp
    
    ' 第二步：遍历所有节的页眉页脚，统计重复出现的文本
    For Each section In doc.Sections
        For Each headerFooter In section.Headers
            ProcessHeaderFooter headerFooter, textDict, totalPages, watermarkTexts
        Next headerFooter
        For Each headerFooter In section.Footers
            ProcessHeaderFooter headerFooter, textDict, totalPages, watermarkTexts
        Next headerFooter
    Next section
    
    ' 第三步：移除所有匹配的水印文本
    For Each section In doc.Sections
        For Each headerFooter In section.Headers
            RemoveWatermarkText headerFooter, watermarkTexts
        Next headerFooter
        For Each headerFooter In section.Footers
            RemoveWatermarkText headerFooter, watermarkTexts
        Next headerFooter
    Next section
    
    ' 恢复Word设置
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = wdAlertsAll
        .AutoSaveOn = True
        .PrintCommunication = True
    End With
    
    MsgBox "水印移除完成。"
End Sub

' 辅助过程：处理单个页眉/页脚，统计文本出现的页面覆盖情况
Private Sub ProcessHeaderFooter(hf As HeaderFooter, textDict As Object, totalPages As Long, watermarkTexts As Collection)
    Dim shp As Shape
    Dim text As String
    Dim pageSet As Object
    
    If hf.Shapes.Count = 0 Then Exit Sub
    
    For Each shp In hf.Shapes
        If shp.Type = msoTextBox And shp.TextFrame.HasText Then
            text = Trim(shp.TextFrame.TextRange.Text)
            ' 跳过空文本或过短的文本（非水印）
            If Len(text) < 5 Then GoTo NextShape
            
            ' 初始化或更新文本的页面集合
            If Not textDict.Exists(text) Then
                Set pageSet = CreateObject("Scripting.Dictionary")
                textDict.Add text, pageSet
            End If
            Set pageSet = textDict(text)
            
            ' 获取当前页眉/页脚所属的页面范围
            Dim startPage As Long, endPage As Long
            startPage = hf.Range.Information(wdActiveEndPageNumber)
            endPage = startPage + hf.Range.ComputeStatistics(wdStatisticPages) - 1
            
            ' 将页面范围加入集合
            Dim i As Long
            For i = startPage To endPage
                If Not pageSet.Exists(i) Then
                    pageSet.Add i, True
                End If
            Next i
            
            ' 如果文本覆盖所有页面，加入水印列表（避免重复添加）
            If pageSet.Count = totalPages Then
                On Error Resume Next
                watermarkTexts.Add text, Key:=text
                On Error GoTo 0
            End If
        End If
NextShape:
    Next shp
End Sub

' 辅助过程：移除页眉/页脚中的水印文本
Private Sub RemoveWatermarkText(hf As HeaderFooter, watermarkTexts As Collection)
    Dim shp As Shape
    Dim text As String
    Dim findRange As Range
    
    If hf.Shapes.Count = 0 Then Exit Sub
    
    For Each shp In hf.Shapes
        If shp.Type = msoTextBox And shp.TextFrame.HasText Then
            Set findRange = shp.TextFrame.TextRange
            For Each text In watermarkTexts
                With findRange.Find
                    .Text = text
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = wdFindStop
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = True ' 匹配完整水印文本，避免误删
                    .MatchWildcards = False
                    .Execute Replace:=wdReplaceAll
                End With
            Next text
            ' 如果文本框为空，直接删除
            If Not shp.TextFrame.HasText Then shp.Delete
        End If
    Next shp
End Sub

内容的提问来源于stack exchange，提问作者Ttop133