Word宏崩溃求助：高亮指定文字时程序卡顿黑屏

问题根源 #

你的宏出现卡顿甚至黑屏的核心原因是完全错误的嵌套循环逻辑：

• 外层遍历文档的每一个单词（For Each Word In ActiveDocument.Words），内层又对每个关键词执行全局替换（Replace:=wdReplaceAll）
• 这意味着每个关键词会被重复执行N次（N是文档的单词总数），文档稍大就会产生巨量无意义的重复操作，直接耗尽Word资源导致卡死

修复后的宏代码 #

Sub HighlightWords()
    Dim WordCollection As Variant
    Dim Words As Variant
    
    ' 定义需要高亮的词汇列表（直接用数组更灵活，不用手动改长度）
    WordCollection = Array( _
        "Exhibit", "with regard", "reviewer", "instruction", _
        "subrogation document", "montreal", "quebec", "Final", _
        "document", "me", "service", "improvement", "inc", _
        "tenant's improvement", "Inc.", "Mrs.", "Policy", "clause" _
    )
    
    ' 关闭屏幕刷新，大幅提升运行速度
    Application.ScreenUpdating = False
    
    ' 设置高亮颜色
    Options.DefaultHighlightColorIndex = wdRed
    
    ' 初始化Find/Replace对象（基于文档内容而非选区，更稳定）
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    
    ' 遍历每个关键词，执行一次全局替换
    For Each Words In WordCollection
        With ActiveDocument.Content.Find
            .Text = Words
            .Execute Replace:=wdReplaceAll
        End With
    Next
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
End Sub

优化说明 #

• 移除了无意义的外层单词遍历，每个关键词只执行一次全局替换，彻底消除重复操作
• 添加Application.ScreenUpdating = False关闭实时屏幕刷新，避免Word频繁重绘导致的卡顿
• 改用ActiveDocument.Content.Find替代Selection.Find，不依赖当前选区，运行更稳定
• 把固定长度数组改成动态Array()，新增/删除词汇时不用手动修改数组定义

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