Link to home
Start Free TrialLog in
Avatar of Enrique A. Santos KM4ZQC
Enrique A. Santos KM4ZQCFlag for United States of America

asked on

Automatic Email Reminder

Need email sent automatically when date is entered in any independent cell in column E3:E45.

Option Explicit

Sub email()

 Dim r As Range
    Dim cell As Range

    Set r = Range("E3:E45")

    For Each cell In r

        If cell.Value = Date Then

            Dim Email_Subject, Email_Send_From, Email_Send_To, _
            Email_Cc, Email_Bcc, Email_Body As String
            Dim Mail_Object, Mail_Single As Variant

            Email_Subject = "Trucks Due for B Service"
            Email_Send_From = ".com"
            Email_Send_To = ".com"
            Email_Cc = ""
            Email_Bcc = ""
            Email_Body = "body"

            On Error GoTo debugs
            Set Mail_Object = CreateObject("Outlook.Application")
            Set Mail_Single = Mail_Object.CreateItem(0)
            With Mail_Single
            .Subject = Email_Subject
            .To = Email_Send_To
            .cc = Email_Cc
            .BCC = Email_Bcc
            .Body = Email_Body
            .send
            End With

        End If

    Next


    Exit Sub

debugs:
        If Err.Description <> "" Then MsgBox Err.Description
End Sub

Open in new window

(Edit: Added CODE tags)
Nestle-Water-B-Service-Master-Testi.xlsm
ASKER CERTIFIED SOLUTION
Avatar of byundt
byundt
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Enrique A. Santos KM4ZQC

ASKER

Please check.  Code runs but is not emailing automatically.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, targ As Range
Set targ = Range("E3:E45")  'Watch these cells for changes

Set targ = Intersect(targ, Target)
If Not targ Is Nothing Then
    For Each cel In targ.Cells
        If cel.Value <> "" Then email cel
    Next
End If
End Sub

Sub email(cell As Range)
    Dim Email_Subject, Email_Send_From As String, Email_Send_To As String, Email_Cc As String, Email_Bcc As String, Email_Body As String
    Dim Mail_Object, Mail_Single As Variant

    If IsDate(cell.Value) Then
        Email_Subject = "Trucks Due for B Service"
        Email_Send_From = "enrique_delossanto@swifttrans.com"
        Email_Send_To = "enrique_delossanto@swifttrans.com"
        Email_Cc = ""
        Email_Bcc = ""
        Email_Body = "body"
   
        On Error GoTo debugs
        Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(0)
        With Mail_Single
            .Subject = Email_Subject
            .To = Email_Send_To
            .cc = Email_Cc
            .BCC = Email_Bcc
            .Body = Email_Body
            .send
        End With
   
    End If

debugs:
    If Err <> 0 Then
        If Err.Description <> "" Then MsgBox Err.Description
        Err.Clear
    End If
    On Error GoTo 0
End Sub
I apologize for attaching the wrong workbook to my previous Comment. I subsequently removed it to avoid confusion if somebody else should look at this thread.

Most likely, the failure of the code to run automatically is caused by putting the Worksheet_Change sub in the wrong location. Rightclick the sheet tab, and choose View code... from the resulting dialog. The resulting code pane is where the Worksheet_Change sub has to go.

I revised the email sub slightly because I noticed that Mail_Object hadn't been declared properly. I also updated the email addresses.
Sub email(cell As Range)
    Dim Email_Subject, Email_Send_From As String, Email_Send_To As String, Email_Cc As String, Email_Bcc As String, Email_Body As String
    Static Mail_Object As Object
    Dim Mail_Single As Object

    If IsDate(cell.Value) Then
        Email_Subject = "Trucks Due for B Service"
        Email_Send_From = "enrique_delossanto@swifttrans.com"
        Email_Send_To = "enrique_delossanto@swifttrans.com"
        Email_Cc = ""
        Email_Bcc = ""
        Email_Body = "body"
    
        On Error GoTo debugs
        If Mail_Object Is Nothing Then Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(0)
        With Mail_Single
            .Subject = Email_Subject
            .To = Email_Send_To
            .cc = Email_Cc
            .BCC = Email_Bcc
            .Body = Email_Body
            .send
        End With
    
    End If

debugs:
    If Err <> 0 Then
        If Err.Description <> "" Then MsgBox Err.Description
        Err.Clear
    End If
    On Error GoTo 0
End Sub

Open in new window

Nestle-Water-B-Service-MasterQ28997.xlsm