Excel VBA to Email Each Row based on Criteria

问题

I am trying to get this:

So send Emails that looks like this:

Then have it end up like this:

I need it to skip blank email addresses, insert sent into column V when sent and create a new email for each row when there is an email available. The new email needs the specific info related to that individual row. I'm using an adaptation of Ron de Bruin's code but every time I run it nothing happens. I don't get an error message, nothing.

Code:

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

EDIT:

LCase(Cells(cell.Row, "U").Value) <> "Y" should be:

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

EDIT: I have a new question but was unsure if i should make a new question: I run it, without the Stop, but then it won't stop. It just stays as running. When i run it with the stop I have to re-run it over an over, I just want it to be automated. I tried several things, none worked. When I change .display to .send it only sends the email subject, not the body and I have to constantly hit 'esc' to stop the macro.

回答1:

The code did not work mainly because of the Set OutMail = Nothing in the for-each loop. However, the VBEditor could not have told you this, because of the On Error Resume Next. In general, try to simplify your code to something small & workable and then start making it complicated:

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

Once it works, you may consider adding more conditions to the If cell.Value and fixing the .Body string.

来源：https://stackoverflow.com/questions/49882296/excel-vba-to-email-each-row-based-on-criteria

标签

excel

vba

excel-vba

outlook-vba