我想填写一个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
提前致谢!
如果单元格 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
我想通了。我需要将我设置的 wdoc 放入循环中,因为需要再次设置它才能仍然读取 <>。它在第一个循环中被覆盖。