Word VBA宏问题：提取删除线/双下划线文本至对应文件

原宏存在几个关键问题导致仅能提取首次匹配的文本：

• 循环逻辑错误：将两种格式的查找放在同一循环中，无终止条件且交替处理，无法遍历所有匹配项
• 双下划线格式设置语法错误：.Underline = wdUnderlineDouble = True 不符合VBA语法
• 查找操作缺少必要的Wrap参数，可能导致查找异常终止

以下是修正后的宏代码，可批量提取所有目标格式文本：

Sub WSC_extraction_for_wordcount()
    ' 提取带删除线的文本至target_del.docx，双下划线文本至target_ins.docx
    Dim sourceDoc As Document, delDoc As Document, insDoc As Document
    Dim findRange As Range
    
    Application.ScreenUpdating = False
    
    ' 绑定文档对象（确保三个文档已提前打开）
    Set sourceDoc = Documents("source.docx")
    Set delDoc = Documents("target_del.docx")
    Set insDoc = Documents("target_ins.docx")
    
    ' 处理删除线文本
    Set findRange = sourceDoc.Content
    With findRange.Find
        .ClearFormatting
        .Font.StrikeThrough = True
        .Forward = True
        .Wrap = wdFindStop ' 找到文档末尾即停止
        .Format = True
        .MatchWholeWord = False
        
        Do While .Execute
            ' 复制匹配内容到目标文档
            findRange.Copy
            delDoc.Content.InsertAfter vbCrLf ' 添加换行
            delDoc.Content.PasteAndFormat wdPasteDefault
            findRange.Collapse wdCollapseEnd ' 移动查找范围到匹配项之后
        Loop
    End With
    
    ' 处理双下划线文本
    Set findRange = sourceDoc.Content
    With findRange.Find
        .ClearFormatting
        .Font.Underline = wdUnderlineDouble ' 修正语法错误
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWholeWord = False
        
        Do While .Execute
            findRange.Copy
            insDoc.Content.InsertAfter vbCrLf
            insDoc.Content.PasteAndFormat wdPasteDefault
            findRange.Collapse wdCollapseEnd
        Loop
    End With
    
    Application.ScreenUpdating = True
    MsgBox "提取完成！", vbInformation
End Sub

关键修复说明： #

• 分离两种格式的处理逻辑，分别遍历所有匹配项
• 使用Range对象代替Selection，避免因选区切换导致的错误
• 修正双下划线格式设置的语法错误
• 设置Wrap = wdFindStop确保查找至文档末尾即停止，避免无限循环
• 添加文档对象绑定，代码更稳定且可读性更高
• 最后弹出提示框告知提取完成

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