运行Mailmerge不止一次

如何解决运行Mailmerge不止一次

所以我有下面的代码（它的宏通过excel文件发送带有邮件合并的电子邮件），当我第一次运行它时可以，但是如果我第二次运行，我得到了462（删除服务器计算机不存在或不可用）。我知道这是由占用变量引起的。但是我尽了一切努力来防止这种情况的发生。有人可以告诉我如何调整代码，使其在不关闭文件的情况下运行多次吗？

Sub Send_Emails()

    Application.ScreenUpdating = False
    
    Dim wrd As Word.Application
    Dim Doc1 As Document,Doc2 As Document,Doc3 As Document,Doc4 As Document
    Dim StrDoc As String,listofDocuments As String

    Set wrd = CreateObject("Word.Application")
    
    listofDocuments = ThisWorkbook.Path & "\Templates\Germany\Supervisors\listofDocuments.docx"
    Set Doc1 = wrd.Documents.Open(listofDocuments)

    With Doc1.MailMerge
      If .State = wdMainAndDataSource Then
        .Destination = wdSendToNewDocument
        .Execute
      End If
    End With
    
    Set Doc2 = ActiveDocument
    
    ActiveDocument.SaveAs (ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx")
    
    Call EmailMergeTableMaker(Doc2)

    With Doc2
      .SaveAs (ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx")
    End With
    
    Set Doc3 = Documents.Open(Filename:=ThisWorkbook.Path & "\Templates\Germany\Supervisors\SupervisorEmail.docx",_
      AddToRecentFiles:=False)
      
    With Doc3.MailMerge
      .MainDocumentType = wdEMail
      .OpenDataSource Name:=(ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx"),ConfirmConversions:=False,ReadOnly:=False,_
        LinkToSource:=True,AddToRecentFiles:=False,Connection:="",sqlStatement:="",_
        sqlStatement1:="",SubType:=wdMergeSubTypeOther
      If .State = wdMainAndDataSource Then
        .Destination = wdSendToNewDocument
        .Execute
      End If
    End With
    
    ActiveDocument.SaveAs (ThisWorkbook.Path & "\Templates\Germany\Supervisors\EmailsToSend.docx")
    Set Doc4 = Documents.Open(ThisWorkbook.Path & "\Templates\Germany\Supervisors\EmailsToSend.docx")
    
    Doc3.Close SaveChanges:=False
    Set Doc3 = nothing
    
    Call SendEmailsOutlook
    
    Doc1.Close SaveChanges:=False
    Doc2.Close SaveChanges:=False
    Doc4.Close SaveChanges:=False
    
    Set Doc1 = nothing
    Set Doc2 = nothing
    Set Doc4 = nothing
    
    wrd.Quit
    Set wrd = nothing
    
    Application.ScreenUpdating = True
    'ThisWorkbook.Close
    
    ThisWorkbook.Saved = True
    'Application.Quit
    
End Sub
Sub SendEmailsOutlook()

  Dim oItem As Outlook.MailItem
  Dim j As Long
  Dim oAccount As Outlook.Account
  Dim Source As Document,MailList As Document
  Dim Recipient As String,MailListDocument As String,SourceDocument As String
  
  MailListDocument = ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx"
  SourceDocument = ThisWorkbook.Path & "\Templates\Germany\Supervisors\EmailsToSend.docx"
  
  Set MailList = Documents.Open(MailListDocument)
  Set Source = Documents.Open(SourceDocument)
  

    For j = 1 To Source.Sections.Count - 1
        Set oItem = CreateObject("outlook.application").CreateItem(olMailItem)
            For Each oAccount In outlook.application.Session.Accounts
                If oAccount = "xxxxxx" Then 'xxxxxx
                    With oItem
                    '.SentOnBehalfOfName = "xxxxxx"
                    '.Attachments.Add ThisWorkbook.Path & "xxxxxx"
                    .Subject = "xxxxxx"
                    .HTMLBody = Source.Sections(j).Range.Text
                    Recipient = Left(MailList.Tables(1).Cell(j + 1,1).Range.Text,Len(MailList.Tables(1).Cell(j + 1,1).Range.Text) - 1)
                    If Len(Recipient) < 3 Then Exit For
                    .SendUsingAccount = oAccount
                    .To = "xxxxxx"
                    '.To = Recipient
                    .Send
                    End With
                    Set oItem = nothing
                End If
            Next
    Next j

End Sub
Sub EmailMergeTableMaker(DocName As Document)

    Dim oTbl As Object
    Dim i As Integer,j As Integer
    Dim oRow As Object
    Dim oRng As Object
    Dim strTxt As String
    
    
    With DocName
      .Paragraphs(1).Range.Delete
      Call TableJoiner
      For Each oTbl In .Tables
      j = 4
        With oTbl
          i = .Columns.Count - j
          For Each oRow In .Rows
            Set oRng = oRow.Cells(j).Range
            With oRng
              .MoveEnd Unit:=wdCell,Count:=i
              .Cells.Merge
              strTxt = Replace(.Text,vbCr,vbTab)
              On Error Resume Next
              If Len(strTxt) > 1 Then .Text = Left(strTxt,Len(strTxt) - 2)
            End With
          Next
        End With
      Next
      For Each oTbl In .Tables
        For i = 1 To j
          oTbl.Columns(i).Cells.Merge
        Next
      Next
      
      With .Tables(1)
        .Rows.Add BeforeRow:=.Rows(1)
        .Cell(1,1).Range.Text = "Recipient"
        .Cell(1,2).Range.Text = "Name"
        .Cell(1,3).Range.Text = "Gender"
        .Cell(1,4).Range.Text = "List"
      End With
      .Paragraphs(1).Range.Delete
      
      Call TableJoiner
      
    End With
    
    Set oRng = nothing
    
End Sub
Private Sub TableJoiner()
    
    Dim wrd2 As Object,doc As Object,tbl As Object
    Dim oTbl As Table
    
    Set wrd2 = Getobject(,"Word.Application")
    Set doc = wrd2.Documents.Open(ThisWorkbook.Path & "\Templates\Germany\Supervisors\Recipients.docx")
    
    For Each tbl In doc.Tables
      With tbl.Range.Next
        If .information(wdWithInTable) = False Then .Delete
      End With
    Next
    
    Set wrd = nothing
End Sub

感谢任何建议！