Vba 电子邮件宏每40-50封电子邮件暂停一次

我有一个半工作宏

循环浏览经理列表

为每个经理生成电子邮件正文

筛选与每个经理相关的所有数据表

将可见单元格转换为HTML表格

将表格添加到电子邮件中

发送

问题是宏在中每50次迭代就停止生成电子邮件，并且不会出错-它只是看起来“运行”而不做任何事情。我已经手动停止了宏，并且没有一致的行被卡住。我尽可能地把这些都删掉，但我不知道问题出在哪里。当我介入时，我无法重现问题。当我重新运行时，第一个50ish运行正常，然后停止生成

我还尝试添加

应用程序。在每个循环迭代结束时等待
调用，并得到相同的问题

我最终不得不按住CTRL+BREAK键来停止宏。当我重新启动它时，它的代码就在它停止的地方开始，并且它发送下一个批处理的结果很好（这意味着当我再次启动时，它在运行时暂停的那行结果很好）。这个问题并不是每隔一段时间就发生一次，而是像时钟一样被卡住了


宏的开始（仅生成文本体）

生成电子邮件，调用HTML表格生成器宏，添加HTML表格，发送电子邮件

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

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

非常高兴，但也很恼火地说，在函数
RangetoHTML
中添加
application.Wait
一秒钟，解决了这个问题

    '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

“关闭TempWB”
TempWB.Close savechanges:=False
'删除此函数中使用的htm文件
杀死临时文件
Application.Wait Now+#12:00:01 AM#“这代码太多了。我不知道如何将其缩小并显示正确的部分，因为我不知道是什么导致了暂停。您是否尝试在
发送方
中注释错误处理程序？是@TimWilliams-相同的问题。不会发生错误，宏将继续运行，但Outlook发件箱不会继续爬升。我基本上一直在做暂停/中断热键，点击调试，然后点击播放，它会从没有问题的地方恢复。每发50封电子邮件（大约10万封，这并不理想），我就得在这封邮件上把头撞到墙上。没有发现错误，vba也不会给我错误。只是一个暂停-没有其他想法-可能会添加一些登录到您的代码，让您知道它在做什么-如果它仍然在运行，那么它一定在做一些事情。。。
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

    '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