Send separate e-mail to every e-mail address in a column

[sspatriots]

Good morning,

I found the code below from Ron de Bruin's website that I think I can use, but can't get it to work at all. Also I need it to start in cell A5 and loop down until the first blank cell in that column and stop. Any help would be greatly appreciated. My columns are as follows:

AI = Customer Contact's Name
AL = Contact's E-mail Address
AO = Yes/No, If "Yes" send the E-mail

Right now the code doesn't do anything, so not sure what I'm missing.

Sub Test1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'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
    
  
    For Each cell In Columns("AL").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "AO").Value) = "Yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "AI").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date by & Cells(cell.Row, "L").Value & ".""
                'You can add files also like this
                '.Attachments.Add ("C:\test.txt")
                .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

 

[Logit]

The following will work :

Option Explicit


Sub SndEMail()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

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

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

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = Cells(cell.Row, "AL").Value                                'cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "AI").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date"
                'You can also add files like this:
                '.Attachments.Add ("C:\test.txt")
                '.Send  'Or use Display.
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

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

 

[sspatriots]

Thanks, I'll give it a try and let you know.

 

[sspatriots]

That seems to be working. Thank you. I just have one more question. The column "AI" that has the contact names in it has first and last names. Is there a way to extract just the first name from that cell to put in the email body? For example if the contact name were "John Smith", I would need the following:

Dear John,

Please contact us to discuss bringing your account up to date.

 

[Logit]

Option Explicit

Sub SndEMail()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

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

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

            Set OutMail = OutApp.CreateItem(0)
            
            Dim FullName As String
            Dim FirstName As String
            Dim LastName As String
            Dim SpacePos As Integer
            
            FullName = Cells(cell.Row, "AI").Value
            SpacePos = InStr(FullName, " ")
            FirstName = Left(FullName, SpacePos - 1)
            LastName = Right(FullName, Len(FullName) - Len(FirstName))
            
            
            On Error Resume Next
            With OutMail
                .To = Cells(cell.Row, "AL").Value    'cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & FirstName & "," _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date"
                'You can also add files like this:
                '.Attachments.Add ("C:\test.txt")
                '.Send  'Or use Display.
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

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

 

[sspatriots]

That's perfect. You made my day...

 

[Logit]

You are welcome.

 

[Jim Gordon]

Good morning,

I found the code below from Ron de Bruin's website that I think I can use, but can't get it to work at all. Also I need it to start in cell A5 and loop down until the first blank cell in that column and stop. Any help would be greatly appreciated. My columns are as follows:

AI = Customer Contact's Name
AL = Contact's E-mail Address
AO = Yes/No, If "Yes" send the E-mail

Right now the code doesn't do anything, so not sure what I'm missing.

Sub Test1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'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
   
 
    For Each cell In Columns("AL").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "AO").Value) = "Yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "AI").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date by & Cells(cell.Row, "L").Value & ".""
                'You can add files also like this
                '.Attachments.Add ("C:\test.txt")
                .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

Were you looking at the code for Windows? Ron has a separate site for Mac. Check out this page.

 

[sspatriots]

Were you looking at the code for Windows? Ron has a separate site for Mac. Check out this page.

I managed to resolve this by the post #5. Thank you anyway

 

[Jim Gordon]

I'm sorry I didn't notice the post marked as Solution. I'm glad this was resolved. The thread came to the top of my list and I should have seen the solution was there already.