Макрос паузы электронной почты каждые 40 - 50 писем

Question

У меня есть макрос, который

1. Просматривает список менеджеров
2. Создает тело электронной почты для каждого менеджера
3. Фильтрует лист всех соответствующих данных для каждого менеджера
4. Преобразует видимые ячейки в HTML таблицу
5. Добавляет таблицу в электронную почту
6. Отправить

Проблема заключается в макрос перестает генерировать электронные письма каждые 50 итераций и не выдает ошибку - он просто «запускается», ничего не делая. Я вручную остановил макрос, и нет единой строки, которая застревает. Сокращая это до минимума, насколько я могу, но я понятия не имею, где проблема. Когда я перехожу, я не могу воссоздать проблему. Когда я перезапускаю, первый 50i sh go исправен, а затем он прекращает генерировать.

Я также попытался добавить вызов Application.Wait в конце каждой итерации l oop и получить то же самое Проблема

---

Запуск макроса (просто генерирует текстовое тело)

Sub Initiate()

    Dim EmailBody As String
    EmailBody = "HTML TEXT BODY HERE"

    Builder EmailBody     '<---- Call loop

End Sub

Выполняет l oop для менеджеров и фильтрует другие лист для соответствующих данных. Передает все диапазоны в макрос для создания электронной почты

Sub Builder(EmailBody As String)

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Distro List")
Dim Raw As Worksheet: Set Raw = ThisWorkbook.Sheets("Email Data")

Dim LR As Long, LR2 As Long
Dim EmailTable As Range, Target As Range, EmailRange As Range

LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Set EmailRange = ws.Range("C2:C" & LR)
LR2 = Raw.Range("A" & Raw.Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For Each Target In EmailRange
    If Target.Offset(, -2) = "y" Then
        If Len(Target.Offset(, -1)) = 6 Then
            If Right(Target.Offset(, 1), 7) = "@so.com" Or Right(Target.Offset(, 1), 11) = "@StackO.com" Then


                Raw.Range("A1:H" & LR2).AutoFilter 1, Target.Offset(, -1), VisibleDropDown:=False
                Raw.Range("A1:H" & LR2).SpecialCells(xlCellTypeVisible).Columns.AutoFit
                Set EmailTable = Raw.Range("A1:H" & LR2).SpecialCells(xlCellTypeVisible)

                Sender EmailBody, EmailTable, Target

                Set EmailTable = Nothing

            End If
        End If
    End If
Next Target

Application.ScreenUpdating = True

End Sub

Создание электронной почты, вызов HTML Макрос генератора таблиц, добавление HTML Таблица, ОТПРАВИТЬ электронную почту

Sub Sender(EmailBody As String, EmailTable As Range, Target As Range)

Dim OutApp As Object
Dim OutMail As Object

On Error GoTo BNP:

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .SentOnBehalfOfName = "urdearboy@so.com"
            .to = Target.Offset(, 1)
            .Subject = "Your Employees....."
            .HTMLBody = "<p style = 'font-family:arial' >" _
                        & EmailBody & "</p>" _
                        & RangetoHTML(EmailTable) _
                        & "<p style = 'font-family:arial' >"

            .Send

            Target.Offset(, -2) = "Sent"
        End With

BNP:
    Set OutApp = Nothing
    Set OutMail = Nothing

End Sub

Макрос, который я обнаружил в сети и преобразует диапазон Excel в таблицу HTML, которую можно вставить в электронную почту.

Function RangetoHTML(EmailTable As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    EmailTable.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function