大家好，我最近在写VBA代码实现一个需求：把当前激活的Word文档里所有包含特定文本的句子复制到一个新建的空白文档中。但目前代码出了问题——所有粘贴操作都跑到原文档的末尾去了，完全没到新文档里，原文档本身已经很大了，这完全不是我想要的结果。

我写的代码如下：

Sub FindWordCopySentenceToSecondDocument()

' the current document

Dim aRange As Range

Set aRange = ActiveDocument.Range

' the new document

Dim mWord As Object

Set mWord = CreateObject(Class:="Word.Application")

mWord.Visible = True

mWord.Activate

Dim NewDocument

Set NewDocument = mWord.Documents.Add

Dim docRng

Set docRng = NewDocument.Range

With aRange.Find

Do

.Text = "the one" ' the word I am looking for

.Execute

If .Found Then

aRange.Expand Unit:=wdSentence

aRange.Copy

aRange.Collapse wdCollapseEnd

' now copy to the other word. This is making problems!

' move the cursor to the end of the document:

Selection.EndKey Unit:=wdStory

' now paste, and insert also a carriage return:

Selection.Paste

Selection.TypeParagraph

End If

Loop While .Found

End With

Set aRange = Nothing

End Sub

问题分析 #

出现这个问题的核心原因是：你代码里的Selection对象默认指向的是**原文档（ActiveDocument）**的选区，即使你新建了Word实例和新文档，但没有把操作上下文切换到新文档，所以所有的粘贴、换行操作都跑到原文档里去了。而且依赖Selection来操作文档本身就不够可靠，最好直接通过Range对象来处理新文档的内容。

修正后的代码 #

下面是调整后的代码，解决了文档切换的问题，同时优化了查找和复制的逻辑：

Sub FindWordCopySentenceToSecondDocument()
    ' 当前文档的Range
    Dim aRange As Range
    Set aRange = ActiveDocument.Range
    
    ' 新建Word应用和文档
    Dim newWordApp As Object
    Set newWordApp = CreateObject(Class:="Word.Application")
    newWordApp.Visible = True ' 让新应用可见
    
    Dim targetDoc As Object
    Set targetDoc = newWordApp.Documents.Add
    
    ' 目标文档的Range，用来定位粘贴位置
    Dim targetRng As Object
    Set targetRng = targetDoc.Range
    
    With aRange.Find
        .Text = "the one" ' 要查找的特定文本
        .Forward = True
        .Wrap = wdFindStop ' 避免循环查找整个文档
        .MatchCase = False ' 根据需求设置是否区分大小写
        
        Do While .Execute
            ' 扩展到整个句子
            aRange.Expand Unit:=wdSentence
            
            ' 将复制的内容粘贴到目标文档的末尾
            targetRng.Collapse Direction:=wdCollapseEnd ' 移动到目标文档末尾
            targetRng.Paste ' 粘贴内容
            targetRng.InsertParagraphAfter ' 插入换行
            
            ' 折叠原文档的Range，继续查找下一个匹配项
            aRange.Collapse Direction:=wdCollapseEnd
        Loop
    End With
    
    ' 释放对象
    Set aRange = Nothing
    Set targetRng = Nothing
    Set targetDoc = Nothing
    Set newWordApp = Nothing
End Sub

关键修改说明 #

1. 直接操作目标文档的Range：不再使用Selection，而是通过targetRng来定位新文档的粘贴位置，彻底避免了原文档的干扰。
2. 优化查找循环逻辑：设置.Wrap = wdFindStop防止无限循环，同时明确.Forward = True确保向前查找。
3. 正确管理对象：添加了对象释放的代码，避免内存泄漏。
4. 简化粘贴流程：每次粘贴后直接在目标文档末尾插入换行，确保每个句子单独成段。

运行这段代码后，所有包含"the one"的句子都会被复制到新建的文档中，完全不会影响原文档的内容。

备注：内容来源于stack exchange，提问作者Ziad El Hachem