Use the Back button in your browser to go back to the website



'This example you can use if you have duplicate addresses in your column.
'It use the "Scripting.Dictionary", Idea from Patrick Molloy to be sure that
'a mail is sent only ones to each address
'You must also add a reference to the Microsoft Scripting Runtime to use it.


Sub TestFile2_Unique()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Addresslist As Scripting.Dictionary

    Application.ScreenUpdating = False
    Set Addresslist = New Scripting.Dictionary
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon

    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" Then
            On Error Resume Next
            Addresslist.Add cell.Value, cell.Value
            If Err.Number = 0 Then
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = cell.Value
                    .Subject = "Reminder"
                    .Body = "Dear " & Cells(cell.Row, "A").Value _
                          & vbNewLine & vbNewLine & _
                            "Please contact us to discuss bringing " & _
                            "your account up to date"
                    'You can add files also like this
                    '.Attachments.Add ("C:\test.txt")
                    .Display  'Or use Send
                End With
                Set OutMail = Nothing
            End If
            On Error GoTo 0
        End If
    Next cell

    Set OutApp = Nothing
    Set Addresslist = Nothing
    Application.ScreenUpdating = True
End Sub