在不关闭Excel的情况下多次运行Excel邮件合并代码

Question

我从Excel执行邮件合并。它第一次运行时工作，但为了让它再次运行，我必须先关闭Excel并重新打开它。我需要能够在不关闭Excel的情况下再次运行它。

Sub MakeReports()
' Open Word and do Mail Merge

'refresh file names in worksheet (refreshes B43 & B35)
Sheets("Input").Select
Range("B36").Select
Selection.ClearContents

' Setup filenames
Const WTempName = "letter.docx" 'This is the 07/10 Word Templates name,  Change as req'd
Dim NewFileName As String
NewFileName = Worksheets("Input").Range("B34").Value & ".docx" 'This is the New 07/10 Word Documents File Name, Change as req'd"

' Setup directories
Dim cDir As String
cDir = ActiveWorkbook.Path + "\" 'Change if appropriate

Dim strpath As String

'Open Help and Information Document
strpath = cDir + "Placement Report Template.docx"
Dim Wd As Object
Dim HelpDoc As Object
Dim f As Boolean
On Error Resume Next
Set HelpDoc = GetObject(strpath, "Word.Application")
HelpDoc.Visible = True
If HelpDoc Is Nothing Then
    Set Wd = GetObject(, "Word.Application")
    If Wd Is Nothing Then
        Set Wd = CreateObject("Word.Application")
        If Wd Is Nothing Then
            MsgBox "Failed to start Word!", vbCritical
            Exit Sub
        End If
        f = True
    End If
    Set HelpDoc = Wd.Documents.Open(strpath)
    If HelpDoc Is Nothing Then
        MsgBox "Failed to open help document!", vbCritical
        If f Then
            Wd.Quit
        End If
        Exit Sub
    End If
    Wd.Visible = True
Else
    With HelpDoc.Parent
        .Visible = True
        .Activate
    End With
End If

'Merge the data

HelpDoc.MailMerge.MainDocumentType = wdFormLetters
HelpDoc.MailMerge.OpenDataSource Name:= _
    cDir + "New and Improved 2.xlsm" _
    , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
    AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
    WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
    Format:=wdOpenFormatAuto, Connection:= _
    "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source= cDir + New and Improved 2.xlsm;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Ty" _
    , SQLStatement:="SELECT * FROM `Placement_Reports`", SQLStatement1:="", _
    SubType:=wdMergeSubTypeAccess
With HelpDoc.MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = Worksheets("Placement Reports").Range("AP1").Value
    End With
    .Execute Pause:=False
End With

' Save and close the new file
ActiveDocument.SaveAs cDir + NewFileName
ActiveDocument.Close

' Close Mail Merge Main Document
HelpDoc.Close savechanges:=wdDoNotSaveChanges
Word.Application.Quit savechanges:=wdDoNotSaveChanges

End Sub