Excel VBA 需要循环和变量才能发送电子邮件，因为 Outlook max

Question

我找到了一个代码，它很好用。但是，由于 Outlook 的最大值为 500，我需要创建一个循环并计算实例数。以下是主要数据列，其他列与宏无关。我似乎无法编写循环代码，因为我对 VBA 有点陌生。 F 列中出现的“x”的数量就是需要计数和循环的数量。预计 F 列中将有 2,500-3,000 个“勾选”，因此将生成 6 封带有循环的电子邮件。

B 列 - 电子邮件地址 F 列 - “x”（小写表示必须发送电子邮件。

Option Explicit

Sub Test1()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

' Change to path of OFT Template (AND user name)
    Set OutEmail = objOutlook.CreateItemFromTemplate("C:\Change Notification.oft")

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "F").Value) = "x" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .SentOnBehalfOfName = "[email protected]"
                .to = cell.Value
                .Send  'Or use Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 1

更改F列中的值。

Exit For

在最大值

Option Explicit

Sub Test1()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    
    Dim sentCount As Long
    Dim sendLimit As Long
    
    sentCount = 0
    sendLimit = 3   ' 500
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        
        If cell.Value Like "?*@?*.?*" And _
          LCase(Cells(cell.Row, "F").Value) = "x" Then

            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .SentOnBehalfOfName = "[email protected]"
                .to = cell.Value
                .Display 'Or .Send
                
                Cells(cell.Row, "F").Value = "Sent"
                sentCount = sentCount + 1
            End With
            
            Set OutMail = Nothing
            
            ' Generally less risk than an =
            If sentCount > sendLimit - 1 Then
                Exit For
            End If
            
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
    Debug.Print sentCount & " emails created."
End Sub

VBA 错误处理 – 完整指南