Email Macro Pauses every 40 - 50 emails

问题

I have working a macro that

Loops through a list of Managers
Generates a email body for each manager
Filters a sheet of all data relevant for each manager
Converts the visible cells to a HTML table
Adds the table to email
Send

The issue is the macro stops generating emails every 50 iterations in and does not error out - it just appears to "run" without doing anything. I have manually stopped the macro and there is no consistent line that appears to be getting stuck. Cutting this down to bare bones as much as I can, but I have no clue where the issue is. When I step through, I can't recreate the issue. When I re-run, the first 50ish go fine and then it stops generating.

I have also tried adding Application.Wait call at the end of each loop iteration and get same issue

Start of macro (just generates a text body)

Sub Initiate()

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

    Builder EmailBody     '<---- Call loop

End Sub

Performs the loop on managers and filters the other sheet for relevant data. Passes all ranges on to the macro to build email

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

Build email, call HTML Table generator macro, add HTML Table, SEND email

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

Macro I found online that converts a excel range to a HTML table that can be inserted into email.

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

来源：https://stackoverflow.com/questions/59866738/email-macro-pauses-every-40-50-emails

标签

vba

outlook