如何用VBA宏填充Word文档且不覆盖基础模板文件？

你直接打开了原始模板文件并执行替换操作，尽管最后用SaveAs2生成了新文件，但关闭模板文档时，Word默认会提示保存修改（若代码未明确禁止），一旦保存就会覆盖原模板。

我们需要基于模板创建副本，在副本上修改内容，确保原模板完全不受影响。以下是两种可靠实现方式：

方式1：用Word的Add方法基于模板新建文档 #

无需手动复制文件，Word会直接基于模板生成新文档（继承格式），在新文档上修改并保存即可：

Sub AnexoF_CPFL()
    Dim Linha As Integer
    Linha = InputBox("Qual a linha do projeto?", "Gerar Anexo F CPFL")
    
    Dim objWord As Object
    Dim arqAnexoF As Object
    Dim conteudo As Object
    Dim templatePath As String
    Dim savePath As String
    
    ' 清理路径中的多余空格，避免识别错误
    templatePath = "C:\Users\Axis\Axis Renováveis Dropbox\Pasta da equipe Axis Renováveis\Axis Renovaveis Server\4 - Operações\1. Desenvolvimento\2. Prospecção\Consultas de Acesso\Macros\Modelos\CPFL\AnexoF.docx"
    savePath = "C:\Users\Axis\Axis Renováveis Dropbox\Pasta da equipe Axis Renováveis\Axis Renovaveis Server\4 - Operações\1. Desenvolvimento\2. Prospecção\Consultas de Acesso\CPFL Paulista\Consultas\"
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    
    ' 基于模板新建文档，而非打开原模板
    Set arqAnexoF = objWord.Documents.Add(Template:=templatePath, NewTemplate:=False)
    Set conteudo = arqAnexoF.Content ' 用Content替代Selection，替换更稳定
    
    ' 执行全局替换
    Dim i As Integer
    For i = 2 To 25
        conteudo.Find.Text = Cells(1, i).Value
        conteudo.Find.Replacement.Text = Cells(Linha, i).Value
        ' 明确Find参数，避免依赖默认设置
        With conteudo.Find
            .MatchCase = False
            .MatchWholeWord = True
            .Execute Replace:=2 ' 用数值2替代wdReplaceAll，避免未引用Word库报错
        End With
    Next
    
    ' 保存最终文件
    arqAnexoF.SaveAs2 Filename:=savePath & "Anexo F - " & Cells(Linha, 2), FileFormat:=17
    
    ' 关闭新文档，原模板未被修改无需担心
    arqAnexoF.Close SaveChanges:=False
    objWord.Quit
    
    ' 释放对象
    Set arqAnexoF = Nothing
    Set conteudo = Nothing
    Set objWord = Nothing
    
    MsgBox "Anexo F CPFL gerado com sucesso!"
End Sub

方式2：手动复制模板到目标目录，再打开副本修改 #

若模板是宏模板（.dotm）或方式1有兼容性问题，可先复制模板再修改：

Sub AnexoF_CPFL()
    Dim Linha As Integer
    Linha = InputBox("Qual a linha do projeto?", "Gerar Anexo F CPFL")
    
    Dim objWord As Object
    Dim arqAnexoF As Object
    Dim conteudo As Object
    Dim templatePath As String
    Dim tempPath As String
    Dim savePath As String
    
    templatePath = "C:\Users\Axis\Axis Renováveis Dropbox\Pasta da equipe Axis Renováveis\Axis Renovaveis Server\4 - Operações\1. Desenvolvimento\2. Prospecção\Consultas de Acesso\Macros\Modelos\CPFL\AnexoF.docx"
    savePath = "C:\Users\Axis\Axis Renováveis Dropbox\Pasta da equipe Axis Renováveis\Axis Renovaveis Server\4 - Operações\1. Desenvolvimento\2. Prospecção\Consultas de Acesso\CPFL Paulista\Consultas\"
    tempPath = savePath & "Temp_AnexoF.docx" ' 临时副本路径
    
    ' 复制模板到临时路径
    FileCopy templatePath, tempPath
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    
    ' 打开临时副本进行修改
    Set arqAnexoF = objWord.Documents.Open(tempPath)
    Set conteudo = arqAnexoF.Content
    
    ' 执行替换操作
    Dim i As Integer
    For i = 2 To 25
        conteudo.Find.Text = Cells(1, i).Value
        conteudo.Find.Replacement.Text = Cells(Linha, i).Value
        With conteudo.Find
            .MatchCase = False
            .MatchWholeWord = True
            .Execute Replace:=2
        End With
    Next
    
    ' 保存为最终文件
    arqAnexoF.SaveAs2 Filename:=savePath & "Anexo F - " & Cells(Linha, 2), FileFormat:=17
    
    ' 关闭并删除临时文件
    arqAnexoF.Close SaveChanges:=False
    Kill tempPath
    
    objWord.Quit
    
    ' 释放对象
    Set arqAnexoF = Nothing
    Set conteudo = Nothing
    Set objWord = Nothing
    
    MsgBox "Anexo F CPFL gerado com sucesso!"
End Sub

• 清理路径空格：原模板路径中存在多余空格，建议修正为标准路径，避免文件识别错误。
• 优先用Content替换：Selection依赖光标位置，Document.Content能确保全局替换更稳定。
• 常量替代：未引用Word对象库时，wdReplaceAll会报错，用数值2替代更安全。
• Dropbox同步问题：确保模板文件未被Dropbox同步锁定，否则可能导致复制失败。

内容的提问来源于stack exchange，提问作者Rogério Ribeiro