Word VBA查找高亮文本页码报错且大文档崩溃问题求助

问题现象 #

• 32页/5719字的小文档：运行耗时约15秒，误报第3页存在高亮（实际为无高亮的目录页），仅第4页有真实高亮
• 55页/10086字的大文档：Word直接冻结崩溃，等待5分钟未恢复，CPU占用率不足10%

原代码问题分析 #

1. 效率低下：未禁用屏幕刷新，每次查找都会触发界面重绘，拖慢执行速度；且未对重复页码去重，冗余操作增多
2. 页码误判：使用wdActiveEndPageNumber获取页码时，若查找范围的边界处于页尾，容易返回下一页的页码，尤其在目录这类特殊区域更易出现错误
3. 崩溃隐患：依赖Selection对象进行操作，频繁的界面交互和未优化的Range循环，会导致Word资源调度异常，引发无响应

修复后的代码 #

' 查找高亮文本并返回唯一页码
Sub FindHighlightedPages()
    Dim hlpagenums As String
    Dim rng As Range
    Dim currentPage As Integer
    Dim lastPage As Integer
    
    ' 禁用屏幕刷新，提升运行速度
    Application.ScreenUpdating = False
    
    hlpagenums = ""
    lastPage = 0
    
    Set rng = ActiveDocument.Content
    With rng.Find
        .ClearFormatting
        .Format = True
        .Highlight = True
        .Forward = True
        .Wrap = wdFindStop ' 避免循环查找
        
        Do While .Execute()
            ' 获取当前高亮文本所在的真实页码
            currentPage = rng.Information(wdFirstCharacterPageNumber)
            
            ' 仅记录未重复的页码
            If currentPage <> lastPage Then
                hlpagenums = hlpagenums & currentPage & ", "
                lastPage = currentPage
            End If
            
            ' 折叠Range到当前找到内容的末尾，继续查找
            rng.Collapse wdCollapseEnd
        Loop
    End With
    
    ' 处理结果并弹窗
    If hlpagenums <> "" Then
        hlpagenums = Left(hlpagenums, Len(hlpagenums) - 2)
        MsgBox "Highlighted text found on page(s): " & hlpagenums
    Else
        MsgBox "No highlighted text found."
    End If
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
End Sub

关键修复点 #

• 禁用屏幕刷新：减少界面重绘操作，大幅提升运行速度
• 页码去重：记录上一次的页码，避免重复添加相同页码
• 精准页码判断：使用wdFirstCharacterPageNumber获取高亮文本首字符所在页码，避免边界误判
• 避免Selection依赖：直接操作文档Content的Range，减少界面交互引发的资源问题
• 设置查找终止规则：Wrap = wdFindStop防止查找完成后循环重复

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