Running Mailmerge more than one time - excel

Question

so I have the code bellow (its macro sending emails with mail merge from excel file) and when I run it for the first time it's OK but if I run it for the second time I'm getting the 462 (The remove server machine does not exist or is unavailable). I know that this is caused by occupied variable. But I did everything that I know to prevent this. Could someone tell me how to adjust my code so it can run multiple times without closing the file?
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
Thank for any suggestions!