动态 rngStory.Find.Replacement.Text 每个循环都不会更改（vba）

Question

我想填写一个word文件模板，并将文本框中的文本更改为excel单元格中编写的内容。对于每一行，我想要一个新文档，并且希望粘贴到文档中的文本随 r 更改。我在循环中使用 line replacementText = Sheet1.Cells(r, 3).Value 来完成此操作。然而，在所有文件中，仅打印单元格 (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

提前致谢！

Answer 1

如果单元格 A3 为空白，

Do While

将停止交互。我想这就是您正在寻找的。

Option Explicit
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
    Dim lastRow As Long '**
    lastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row    '**
    r = 2
    For r = 2 To lastRow '**
        If Sheet1.Cells(r, 1) <> "" Then
            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
            wdoc.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 '**
        End If
    Next r '**
End Sub

Answer 2

我想通了。我需要将我设置的 wdoc 放入循环中，因为需要再次设置它才能仍然读取 <>。它在第一个循环中被覆盖。