Automatic e-mail sending VBA Code

[Martyn0299]

Hello Guys

I have a piece of code that will look at a cell (M) and if the value of the cell is = (yes) then it will take the e-mails stored in cell (I) and the name of the client stored in cell (G) and the it will send the e-mail when i run the code.

Ok so where im heading is if someone could help me modify the code in a way that it will not sent the mail multiple emails to the email that it has already been send maybe have another cell to look at width he value (Mail Send). Also i would like for the e-mails to be send automaticly and not when u run the code but when value in cell (M) changes it will send the mail. I have over 100 clients in database and i need to send mails to them when the data is changed,

Here is the code i have:

Sub Sendmail()
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("I").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "M").Value) = "yes" Then


Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Aakash Sehgal"
.Body = "Dear " & Cells(cell.Row, "G").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also by use:
'.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

 

[DanteAmor]

First, so that the mail is not sent again, I changed the cell in "M" to "sent", the updated macro:
This macro can be useful when you want to send the emails again.

Sub Sendmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    On Error Resume Next
    
    For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "M").Value) = "yes" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Aakash Sehgal"
                .Body = "Dear " & Cells(cell.Row, "G").Value _
                    & vbNewLine & vbNewLine & _
                    "Please contact us to discuss bringing " & "your account up to date"
                'You can add files also by use:
                '.Attachments.Add ("C:\test.txt")
                .Send 'Or use Display
                If Err.Number = 0 Then
                    Cells(cell.Row, "M").Value = "sent"
                End If
            End With
            Set OutMail = Nothing
        End If
    Next cell
    
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

---

Now, to work in automatic, put the following code in the events of your sheet. Each time you change a cell in the "M" column, send mail automatically.

Private Sub Worksheet_Change(ByVal Target As Range)
' Sendmail
'
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Application.ScreenUpdating = False
    On Error Resume Next
    
    If Not Intersect(Target, Columns("M")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        If Target.Value <> "yes" Then Exit Sub
        '
        Set OutApp = CreateObject("Outlook.Application")
    
        If Cells(Target.Row, "I").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Cells(Target.Row, "I").Value
                .Subject = "Aakash Sehgal"
                .Body = "Dear " & Cells(Target.Row, "G").Value _
                    & vbNewLine & vbNewLine & _
                    "Please contact us to discuss bringing " & "your account up to date"
                'You can add files also by use:
                '.Attachments.Add ("C:\test.txt")
                .Send 'Or use Display
                If Err.Number = 0 Then
                    Cells(Target.Row, "M").Value = "sent"
                End If
            End With
            Set OutMail = Nothing
        End If
        Set OutApp = Nothing
    End If
    Application.ScreenUpdating = True
End Sub

 

[Martyn0299]

Thank you very much the code is working perfect, will be much easier to notify clients now thank u again

 

[Martyn0299]

First, so that the mail is not sent again, I changed the cell in "M" to "sent", the updated macro:
This macro can be useful when you want to send the emails again.

Sub Sendmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    On Error Resume Next
    
    For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "M").Value) = "yes" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Aakash Sehgal"
                .Body = "Dear " & Cells(cell.Row, "G").Value _
                    & vbNewLine & vbNewLine & _
                    "Please contact us to discuss bringing " & "your account up to date"
                'You can add files also by use:
                '.Attachments.Add ("C:\test.txt")
                .Send 'Or use Display
                If Err.Number = 0 Then
                    Cells(cell.Row, "M").Value = "sent"
                End If
            End With
            Set OutMail = Nothing
        End If
    Next cell
    
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

---

Now, to work in automatic, put the following code in the events of your sheet. Each time you change a cell in the "M" column, send mail automatically.

Private Sub Worksheet_Change(ByVal Target As Range)
' Sendmail
'
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Application.ScreenUpdating = False
    On Error Resume Next
    
    If Not Intersect(Target, Columns("M")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        If Target.Value <> "yes" Then Exit Sub
        '
        Set OutApp = CreateObject("Outlook.Application")
    
        If Cells(Target.Row, "I").Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = Cells(Target.Row, "I").Value
                .Subject = "Aakash Sehgal"
                .Body = "Dear " & Cells(Target.Row, "G").Value _
                    & vbNewLine & vbNewLine & _
                    "Please contact us to discuss bringing " & "your account up to date"
                'You can add files also by use:
                '.Attachments.Add ("C:\test.txt")
                .Send 'Or use Display
                If Err.Number = 0 Then
                    Cells(Target.Row, "M").Value = "sent"
                End If
            End With
            Set OutMail = Nothing
        End If
        Set OutApp = Nothing
    End If
    Application.ScreenUpdating = True
End Sub

Sorry to bother again but to make the code work even better could u help me with this problem i have a date in cell (K) which is changing from time to time and would it be possible to do if the date in the cell (K) is the same as TODAY then change the cell (M) to (Yes) so the email is send again? or maybe some other way for this to happen

Thank u in advance

 

[DanteAmor]

I'm glad to help you