如何用Word VBA提取含指定多词的句子？代码异常求助

问题场景 #

我有一个名为Tst.doc的Word文档，内容如下：

Sofa 1.
Sofa 2.
Chair 1.
Chair 2.
Seat 1.
Seat 2.

需要提取所有包含sofa、chair、seat任意一个单词的句子，保存到D:\OutputBin.doc。现有代码运行不稳定，关键词的顺序会影响提取结果，原因是每次搜索后查找范围未重置，导致后续搜索范围持续缩小。

原代码如下：

Sub Extract_MANY_OR()

Dim liste As String
Dim file1 As String
Dim file2 As String: file2 = "D:\OutputBin.doc"

' Change this every time!
file1 = "D:\TST.doc"
liste = "seat,sofa,chair"
 
Dim i As Integer

' assign variables for the documents
    Dim wrdDoc1 As Document: Set wrdDoc1 = Documents.Open(file1)
    Dim wrdDoc2 As Document: Set wrdDoc2 = Documents.Open(file2)
    Dim r1 As Range: Set r1 = wrdDoc1.Range 
    Dim r2 As Range: Set r2 = wrdDoc2.Range

For i = 0 To UBound(Split(liste, ","))

 With r1
  .Find.Text = Split(liste, ",")(i)
  .Find.MatchCase = False '
  ' .Find.MatchCase = True 
  Do While .Find.Execute
   r1.Expand Unit:=wdSentence
   wrdDoc2.Characters.Last.FormattedText = r1.FormattedText
   r2.InsertParagraphAfter
   r1.Collapse wdCollapseEnd
  Loop
 End With

Next i
 
End Sub

问题原因 #

原代码里r1仅在初始化时被设为整个文档范围，第一次循环搜索完成后，r1.Collapse wdCollapseEnd会把查找范围定位到文档末尾，后续循环搜索其他关键词时，只能从这个末尾位置开始查找，自然无法找到前面的内容，结果完全依赖关键词的顺序。

修正方案 #

每次循环搜索新关键词前，把r1重置为整个文档的范围，确保每个关键词都从文档开头开始搜索。同时可以添加去重逻辑，避免同一个句子因包含多个目标关键词被重复提取。

修正后的代码：

Sub Extract_MANY_OR_Fixed()

    Dim liste As String
    Dim file1 As String
    Dim file2 As String: file2 = "D:\OutputBin.doc"
    
    file1 = "D:\TST.doc"
    liste = "seat,sofa,chair"
     
    Dim i As Integer
    Dim keyword As String
    Dim extractedSentences As Collection ' 存储已提取句子，避免重复
    Set extractedSentences = New Collection
    
    ' 打开文档
    Dim wrdDoc1 As Document: Set wrdDoc1 = Documents.Open(file1)
    Dim wrdDoc2 As Document: Set wrdDoc2 = Documents.Open(file2)
    ' 清空目标文档原有内容（可选）
    wrdDoc2.Content.Delete
    
    For i = 0 To UBound(Split(liste, ","))
        keyword = Split(liste, ",")(i)
        ' 每次循环重置查找范围为整个文档
        Dim r1 As Range: Set r1 = wrdDoc1.Range
        
        With r1.Find
            .Text = keyword
            .MatchCase = False
            .Wrap = wdFindContinue
            .ClearFormatting
        End With
        
        Do While r1.Find.Execute
            r1.Expand Unit:=wdSentence
            Dim sentenceText As String
            sentenceText = Trim(r1.Text)
            
            ' 检查句子是否已提取，避免重复
            On Error Resume Next
            extractedSentences.Add sentenceText, Key:=sentenceText
            If Err.Number = 0 Then
                ' 未重复则写入目标文档
                wrdDoc2.Range.InsertAfter sentenceText
                wrdDoc2.Range.InsertParagraphAfter
            End If
            On Error GoTo 0
            
            ' 折叠范围到当前句子末尾，继续搜索下一个匹配
            r1.Collapse wdCollapseEnd
        Loop
    Next i
    
    ' 保存并关闭文档（可选）
    wrdDoc2.Save
    wrdDoc1.Close SaveChanges:=wdDoNotSaveChanges
    wrdDoc2.Close SaveChanges:=wdSaveChanges
    
End Sub

关键改动说明 #

1. 重置查找范围：在每次循环内部重新设置r1 = wrdDoc1.Range，确保每个关键词的搜索都覆盖整个文档。
2. 添加去重逻辑：用Collection存储已提取句子，利用其键唯一的特性避免重复写入。
3. 完善查找设置：添加.Wrap = wdFindContinue确保搜索到文档末尾后自动从头开始，配合范围重置让搜索更稳妥。
4. 完整流程优化：加入清空目标文档、保存关闭文档的逻辑，让提取流程更闭环。

内容的提问来源于stack exchange，提问作者Ziad El Hachem