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字符串。

Excel VBA根据条件向每行发送电子邮件

1 个答案: