Word VBA提取高亮文本 仅为存在的高亮色新建对应文档

原代码的逻辑缺陷在于循环遍历每个预设高亮颜色时，第一步就直接创建新文档，完全没有提前校验原文档中是否真的存在该颜色的高亮内容，因此无论文档实际包含几种高亮色，都会固定生成和预设颜色数量一致的空白文档。此外原代码还存在三处显性问题：

• Selection.Collapse wdCollapseEndwdYellow存在拼写错误，运行时会直接触发报错
• 多余的分页符插入逻辑：不同颜色的内容存储在独立文档中，完全不需要跨文档插入分页符
• 依赖Selection对象做查找，运行时如果用户误点鼠标改变选中位置，很容易导致提取结果出错

调整执行顺序，对每个待处理的高亮颜色，先预扫描原文档确认存在对应颜色的高亮内容，再新建文档提取内容；没有匹配内容的颜色直接跳过，不生成空白文件。同时修复原有语法错误，替换不稳定的Selection操作为Range对象操作。

修改后完整代码 #

Sub ExtractHighlightedTextsInSameColor()
    Dim objDoc As Document, objDocAdd As Document
    Dim objRange As Range, srcRange As Range
    Dim highliteColor As Variant
    Dim i As Long
    Dim hasMatch As Boolean
    
    ' 保留原代码预设的高亮颜色枚举列表，可按需增减
    highliteColor = Array(wdYellow, wdBlack, wdBlue, wdBrightGreen, wdDarkBlue, _
                        wdDarkRed, wdDarkYellow, wdGreen, wdPink, wdRed, _
                        wdTeal, wdTurquoise, wdViolet, wdWhite)

    Set objDoc = ActiveDocument
    For i = LBound(highliteColor) To UBound(highliteColor)
        hasMatch = False
        ' 第一步：预扫描文档，判断当前颜色是否存在高亮内容
        Set srcRange = objDoc.Content
        With srcRange.Find
            .ClearFormatting
            .Forward = True
            .Format = True
            .Highlight = True
            .Wrap = wdFindStop
            .Execute
            Do While .Found
                If srcRange.HighlightColorIndex = highliteColor(i) Then
                    hasMatch = True
                    Exit Do ' 找到第一个匹配项即可确认存在，终止预扫描
                End If
                srcRange.Collapse wdCollapseEnd
                .Execute
            Loop
        End With
        
        ' 无匹配内容直接跳过，不新建文档
        If Not hasMatch Then GoTo NextColorLoop
        
        ' 确认有对应内容才新建独立文档
        Set objDocAdd = Documents.Add
        Set objRange = objDocAdd.Content
        objRange.Collapse wdCollapseEnd
        
        ' 第二步：遍历提取当前颜色的所有高亮内容写入新文档
        Set srcRange = objDoc.Content
        With srcRange.Find
            .ClearFormatting
            .Forward = True
            .Format = True
            .Highlight = True
            .Wrap = wdFindStop
            .Execute
            Do While .Found
                If srcRange.HighlightColorIndex = highliteColor(i) Then
                    ' 默认复制带格式的高亮文本片段
                    objRange.FormattedText = srcRange.FormattedText
                    ' 若需要复制高亮内容所在的整段文本，注释上一行，启用下一行代码即可
                    ' objRange.FormattedText = srcRange.Paragraphs(1).Range.FormattedText
                    objRange.InsertParagraphAfter
                    objRange.Collapse wdCollapseEnd
                End If
                srcRange.Collapse wdCollapseEnd
                .Execute
            Loop
        End With
        
NextColorLoop:
    Next
End Sub

• 新增预扫描校验逻辑：每个颜色处理前先检查是否存在匹配内容，从根源避免生成无意义的空白文档
• 移除了原代码中多余的分页符插入代码，减少无效操作
• 修复了原代码的拼写错误，避免运行时报错
• 全程使用Range对象完成查找和内容写入，替换原有的Selection操作，运行稳定性更高
• 保留了原代码的可选功能开关：可以根据需求选择仅提取高亮片段，还是提取高亮内容所在的整段文本
• 删除了原代码中声明后从未使用的无效变量strFindColor，精简代码结构

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