在循环到另一个文档之前关闭Word文档

Question

宏从 Excel 行中获取文本，将其保存到 Word 文档，保存 Word 文档，然后循环到另一个 Excel 行。我无法更改宏，以便它在保存后、循环到另一个 Excel 行之前关闭 Word 文档。谁能帮帮我吗？这是我的宏：

Sub ReplaceText()

Dim wApp As Word.Application

Dim wdoc As Word.Document

Dim custN, path As String

Dim r As Long

r = 2

Do While Sheet1.Cells(r, 1) <> ""

Set wApp = CreateObject("Word.Application")

 

wApp.Visible = True

 

Set wdoc = wApp.Documents.Open(Filename:="G:\Shared\macros\final.dotx", ReadOnly:=True)

With wdoc

.Application.Selection.Find.Text = "<<ID>>"

.Application.Selection.Find.Execute

.Application.Selection = Sheet1.Cells(r, 1).Value

.Application.Selection.EndOf


.Application.Selection.Find.Text = "<<date>>"

.Application.Selection.Find.Execute

.Application.Selection = Sheet1.Cells(r, 3).Value

.Application.Selection.EndOf
  

custN = Sheet1.Cells(r, 1).Value & " " & Sheet1.Cells(r, 2).Value

path = "G:\Shared\til arkiv\final settlement forms\"

.SaveAs2 Filename:=path & custN, _

FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False

End With

r = r + 1

Loop


End Sub

尝试过

.Close

但是它留下了空白的Word文档

Answer 1

• 使用

  CreateObject

  创建 Word 对象移至循环之前。使用 Word 应用程序处理所有文档可以节省时间。
• Word 应用程序可能会创建一个空白文档，添加代码来关闭它。

• wApp.Quit

  最后关闭 Word 应用程序。

Sub ReplaceText()
    Dim wApp As Word.Application
    Dim wdoc As Word.Document
    Dim custN, path As String
    Dim r As Long
    r = 2
    Set wApp = CreateObject("Word.Application")  '**
    For Each wdoc In wApp.Documents
        wdoc.Close False
    Next
    wApp.Visible = True  '**
    Do While Sheet1.Cells(r, 1) <> ""
        Set wdoc = wApp.Documents.Open(Filename:="G:\Shared\macros\final.dotx", ReadOnly:=True)
        With wdoc
            .Application.Selection.Find.Text = "<<ID>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Sheet1.Cells(r, 1).Value
            .Application.Selection.EndOf
            .Application.Selection.Find.Text = "<<date>>"
            .Application.Selection.Find.Execute
            .Application.Selection = Sheet1.Cells(r, 3).Value
            .Application.Selection.EndOf
            custN = Sheet1.Cells(r, 1).Value & " " & Sheet1.Cells(r, 2).Value
            path = "G:\Shared\til arkiv\final settlement forms\"
            .SaveAs2 Filename:=path & custN, FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False
            .Close False   '**
        End With
        r = r + 1
    Loop
    wApp.Quit   '**
    Set wApp = Nothing   '**
End Sub