Sub RunMerge()
Application.ScreenUpdating = False
Dim Doc1 As Document, Doc2 As Document, Doc3 As Document, StrDoc As String, i As Long, j As Long
Set Doc1 = ThisDocument
StrDoc = ThisDocument.Path & "\EmailDataSource.doc"
If Dir(StrDoc) <> "" Then Kill StrDoc
With Doc1.MailMerge
  If .State = wdMainAndDataSource Then
    .Destination = wdSendToNewDocument
    .Execute
    Set Doc2 = ActiveDocument
  End If
End With
Call EmailMergeTableMaker(Doc2)
With Doc2
  j = .Tables(1).Rows.Count - 1
  .SaveAs FileName:=StrDoc, AddToRecentFiles:=False, FileFormat:=wdFormatDocument
  StrDoc = .FullName
  .Close
End With
Set Doc2 = Nothing
Set Doc3 = Documents.Open(FileName:=Doc1.Path & "\Email Merge Main Document.doc", _
  AddToRecentFiles:=False)
With Doc3.MailMerge
  .MainDocumentType = wdEMail
  .OpenDataSource Name:=StrDoc, ConfirmConversions:=False, ReadOnly:=False, _
    LinkToSource:=True, AddToRecentFiles:=False, Connection:="", SQLStatement:="", _
    SQLStatement1:="", SubType:=wdMergeSubTypeOther
  If .State = wdMainAndDataSource Then
    '.Destination = wdSendToNewDocument
    .Destination = wdSendToEmail
    .MailAddressFieldName = "Recipient"
    .MailSubject = "Monthly Sales Stats"
    '.MailFormat = wdMailFormatHTML
    .MailFormat = wdMailFormatPlainText
    For i = 1 To j
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
      End With
      .Execute Pause:=False
      Call Pause(10)
    Next i
  End If
End With
Doc3.Close SaveChanges:=False
Set Doc3 = Nothing
Application.ScreenUpdating = True
End Sub

Public Function Pause(Delay As Long)
Dim Start As Long
Start = Timer
If Start + Delay > 86399 Then
  Start = 0: Delay = (Start + Delay) Mod 86400
  Do While Timer > 1
    DoEvents ' Yield to other processes.
  Loop
End If
Do While Timer < Start + Delay
  DoEvents ' Yield to other processes.
Loop
End Function