Excel VBA 根据条件通过电子邮件发送每一行

Question

我想得到这个:

所以发送看起来像这样的电子邮件:

然后让它变成这样:

我需要它来跳过空白的电子邮件地址，在发送时将发送插入 V 列，并在有可用电子邮件时为每一行创建一个新电子邮件。新电子邮件需要与该行相关的特定信息。我正在使用 Ron de Bruin 代码的改编版，但每次运行它时都没有任何反应。我没有收到任何错误消息。

代码:

Sub test2()
'Ron De Bruin Adaptation
'Working in Office 2000-2016

Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

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

On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
For Each cell In Columns("T").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And _
       LCase(Cells(cell.Row, "U").Value) <> "Y" _
       And LCase(Cells(cell.Row, "V").Value) <> "send" Then
        With OutMail
            .To = Cells(cell.Row, "T").Value
            .Subject = "New Work Order Assigned"
            .Body = "Work Order: " & Cells(cell.Row, "G").Value & _
                    "has been assigned to you." & _
                    vbNewLine & vbNewLine & _
                    "Region: " & Cells(cell.Row, "B").Value & vbNewLine & _
                    "District: " & Cells(cell.Row, "C").Value & vbNewLine & _
                    "City: " & Cells(cell.Row, "D").Value & vbNewLine & _
                    "Atlas: " & Cells(cell.Row, "E").Value & vbNewLine & _
                    "Notification Number: " & Cells(cell.Row, "F").Value & vbNewLine & _
            .display  'Or use Send
        End With
        On Error GoTo 0
        Cells(cell.Row, "V").Value = "sent"
        Set OutMail = Nothing
    End If
Next cell

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

编辑:

LCase(Cells(cell.Row, "U").Value) <> "Y"应该是:

LCase(Cells(cell.Row, "U").Value) = "Y"

编辑:我有一个新问题，但不确定是否应该提出一个新问题:我在没有停止的情况下运行它，但它不会停止。它只是保持运行状态。当我用停止运行它时，我必须重新运行它一遍，我只希望它自动化。我尝试了几件事，但都没有用。当我将 .display 更改为 .send 时，它只发送电子邮件主题，而不是正文，我必须不断地点击“esc”来停止宏。

Answer 1

主要是因为 for-each 循环中的 Set OutMail = Nothing 导致代码无法运行。但是，由于 On Error Resume Next，VBEditor 无法告诉您这一点。通常，尝试将您的代码简化为小而可行的代码，然后开始使其复杂化:

Sub test2()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

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

    For Each cell In Worksheets("Sending").Columns("T").Cells
        Set OutMail = OutApp.CreateItem(0)
        If cell.Value Like "?*@?*.?*" Then      'try with less conditions first
            With OutMail
                .To = Cells(cell.Row, "T").Value
                .Subject = "New Work Order Assigned"
                .Body = "Write something small to debug"
                .display
                Stop                            'wait here for the stop
            End With
            Cells(cell.Row, "V").Value = "sent"
            Set OutMail = Nothing
        End If
    Next cell

    'Set OutApp = Nothing                        'it will be Nothing after End Sub
    Application.ScreenUpdating = True

End Sub

一旦成功，您可以考虑向 If cell.Value 添加更多条件并修复 .Body 字符串。