Email Macro Pauses every 40 - 50 emails - vba

Question

I have a semi-working 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
I end up having to CTRL + BREAK to stop the macro. When I restart its coded to pick up right where it left off and it sends the next batch just fine (meaning the line it gets paused on runs just fine when I start again). Issue is not every once in a while - it's gets stuck like clock work.
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

Answer 1

Extremely glad, yet also annoyed, to say that adding a Applitcation.Wait for 1 second to the function RangetoHTML fixed the issue.
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Application.Wait Now + #12:00:01 AM# '<------ Resolved Issue
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Still curious to know what the actual issue is since I suspect that this is a work around to the actual issue. Just glad I can finally use this macro to send large distro's without it pausing every 4 minutes!