VBA循环中rngStory.Find.Replacement.Text未随循环更新问题

我想用Excel单元格内容填充Word模板中的文本框，每一行数据生成一个新文档，通过循环变量r切换替换内容。但运行脚本后，所有生成的文件都只显示单元格(2,3)的内容，脚本如下：

Sub combine()

  Dim wApp As New Word.Application
  wApp.Visible = True
  
  
  Dim wdoc As Word.Document
  Set wdoc = wApp.Documents.Open(fileName:="...", ReadOnly:=True)
  Dim rngStory As Word.Range
  Dim replacementText As String
  Dim measure As String
  Dim path As String
  Dim r As Long
  
    r = 2
  
 
  Do While Sheet1.Cells(r, 1) <> ""    'do this as long as first column cel is not empty

    replacementText = Sheet1.Cells(r, 3).Value 'define replacementtext

  For Each rngStory In wdoc.StoryRanges
    With rngStory.Find
      .Text = "<<goal>>"
      .Replacement.Text = replacementText
      '.Wrap = 1 'wdFindContinue (ensures that if the search reaches the end of rngStory, it continues from the beginning. )
      .Execute Replace:=2  'wdReplaceAll (it replaces all occurrences of the specified text in the range.)
   Debug.Print "Measure: " & measure
   Debug.Print "Replacement Text: " & replacementText
    End With
  Next rngStory

measure = Sheet1.Cells(r, 1).Value 'define measure as the content of the current cel of the first column
    path = "..." ' define the path where things need to be saved
    .SaveAs2 fileName:=path & measure, _
    FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
   
   ' wdoc.SaveAs fileName:=path & measure, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False


'Debug.Print "Replacement Text: " & replacementText
'Debug.Print "r: " & r

r = r + 1
Loop


End Sub

问题原因 #

1. 模板未循环重新加载：你只在循环外打开了一次模板，第一次循环就把模板里的<<goal>>替换成了第2行内容，后续循环时模板里已经没有这个占位符，自然无法替换新内容，所有文件都是基于第一次修改后的模板保存的。
2. 语法错误：.SaveAs2前面多了一个点，正确写法是wdoc.SaveAs2。
3. 变量赋值顺序问题：measure在替换之后才赋值，第一次循环时measure是空值，可能导致第一个文件名异常。

修正后的脚本 #

Sub combine()
    Dim wApp As New Word.Application
    wApp.Visible = True ' 不需要实时查看的话改成False，提升运行速度
    
    Dim wdoc As Word.Document
    Dim rngStory As Word.Range
    Dim replacementText As String
    Dim measure As String
    Dim path As String
    Dim r As Long
    Dim templatePath As String
    
    templatePath = "你的Word模板完整路径" ' 替换为实际模板路径
    path = "生成文件的保存路径" ' 替换为实际保存路径
    r = 2
    
    Do While Sheet1.Cells(r, 1) <> ""
        ' 每次循环重新打开模板，确保基于原始模板修改
        Set wdoc = wApp.Documents.Open(fileName:=templatePath, ReadOnly:=False)
        
        measure = Sheet1.Cells(r, 1).Value ' 提前获取文件名
        replacementText = Sheet1.Cells(r, 3).Value
        
        ' 替换正文区域的占位符
        For Each rngStory In wdoc.StoryRanges
            With rngStory.Find
                .Text = "<<goal>>"
                .Replacement.Text = replacementText
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
            ' 额外处理文本框内的内容（StoryRanges默认不覆盖文本框）
            If rngStory.ShapeRange.Count > 0 Then
                Dim shp As Shape
                For Each shp In rngStory.ShapeRange
                    If shp.Type = msoTextBox Then
                        shp.TextFrame.TextRange.Find.Execute FindText:="<<goal>>", ReplaceWith:=replacementText, Replace:=wdReplaceAll
                    End If
                Next shp
            End If
        Next rngStory
        
        ' 保存生成的文档
        wdoc.SaveAs2 fileName:=path & measure & ".docx", _
                     FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
        
        ' 关闭当前文档，释放资源
        wdoc.Close SaveChanges:=False
        Set wdoc = Nothing
        
        r = r + 1
    Loop
    
    ' 按需关闭Word应用
    ' wApp.Quit
    ' Set wApp = Nothing
End Sub

关键修改说明 #

• 循环加载模板：每次循环都重新打开原始模板，避免占位符被第一次替换后消失。
• 新增文本框处理：原脚本的StoryRanges无法覆盖文本框内容，新增逻辑专门处理文本框内的占位符替换。
• 修正语法错误：修复SaveAs2的调用方式。
• 调整变量顺序：提前获取文件名，避免空值问题。
• 添加文档关闭逻辑：防止同时打开过多文档占用资源。

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