Excel VBA合并Word文档：粘贴覆盖模板及光标定位问题

问题根源分析 #

• 光标定位错误：原代码WordApp.Selection.EndKey未指定范围参数，默认仅移动到当前行末尾，无法到达文档最末端，需指定wdStory参数。
• 粘贴范围错误：WordDoc.Range.Paste会覆盖整个文档的内容，因为WordDoc.Range代表的是整个文档的所有内容范围，正确做法是定位到文档末尾的空白区域再粘贴。
• 冗余的Select操作：TekstModule.Select和WordDoc.Select属于不必要的操作，直接操作Range对象更高效且稳定。

修正后的完整代码 #

Sub ModulesSamenvoegen()
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim PadnaamNaarHandleidingen As String
    Dim RegelCounter As Integer
    Dim ModuleCounter As Integer
    Dim TekstModule As Word.Document
    Dim Template As String
    Dim Taal As String
    Dim blnStart As Boolean
    Dim docEndRange As Range ' 新增：用于定位文档末尾的Range

    Template = PadnaamNaarHandleidingen & "\" & Taal & "\Templates\Masterhandleiding " & Taal & ".dotx"

    ' 检查Word是否已运行
    On Error Resume Next
    Set WordApp = GetObject(Class:="Word.Application")
    If WordApp Is Nothing Then
        Set WordApp = CreateObject(Class:="Word.Application")
        If WordApp Is Nothing Then
            MsgBox "无法启动Word程序！", vbExclamation
            Exit Sub
        End If
        blnStart = True
    End If
    On Error GoTo ErrHandler
    WordApp.Visible = True
    WordApp.Activate
    WordApp.WindowState = wdWindowStateMaximize

    ' 打开模板文档
    Set WordDoc = WordApp.Documents.Open(FileName:=Template)
    ' 定位到文档末尾（替换原错误的EndKey）
    WordApp.Selection.EndKey Unit:=wdStory

    ' 循环合并所有模块文档
    ModuleCounter = 1
    For RegelCounter = 1 To AantalTekstModules
        Set TekstModule = WordApp.Documents.Open(FileName:=PadnaamNaarHandleidingen & "\" & Taal & "\Tekstmodules\" & ModuleNaam(ModuleCounter))
        ' 直接复制文档全部内容，无需Select
        TekstModule.Range.Copy
        TekstModule.Close SaveChanges:=False ' 关闭模块文档，不保存

        ' 定位到目标文档的末尾Range
        Set docEndRange = WordDoc.Range(WordDoc.Range.End - 1, WordDoc.Range.End - 1)
        ' 在末尾粘贴内容
        docEndRange.Paste

        ModuleCounter = ModuleCounter + 1
    Next

    ' 保存并关闭合并后的文档
    WordDoc.Close SaveChanges:=True

ExitHandler:
    On Error Resume Next
    If blnStart Then
        ' 若本程序启动的Word，关闭它
        WordApp.Quit SaveChanges:=False
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

关键修改点说明 #

1. 光标定位修正：将WordApp.Selection.EndKey改为WordApp.Selection.EndKey Unit:=wdStory，确保光标移到文档最末端。
2. 粘贴范围修正：新增docEndRange对象，定位到文档末尾的空白位置，再执行粘贴，避免覆盖原有内容。
3. 移除冗余Select：删除TekstModule.Select和WordDoc.Select，直接通过Range对象操作内容，提升代码稳定性。

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