Excel Automatic Email Reminder

Topic

New Reply

I am sorry for the inconvinience. I am new to this site and was hoping to find someone who could help me with this trouble.
I’m trying to make a macro that would automatically send and email when there is 20 days left to the duedate. This macro would have to run 24/7 (or at least while the pc is on)

[TABLE=”width: 625″]
[TR]
[TD]The document should be as simple as this

[TABLE=”width: 537″]
[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]PERSONAL[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]full name[/TD]
[TD]ID[/TD]
[TD]medical exam[/TD]
[TD]due date[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]first person[/TD]
[TD]35834800[/TD]
[TD]01/10/2017[/TD]
[TD]01/10/2018[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]second person[/TD]
[TD]36987452[/TD]
[TD]25/09/2017[/TD]
[TD]25/09/2018[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]etc[/TD]
[TD]36859500[/TD]
[TD]20/09/2017[/TD]
[TD]20/09/2018[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]etc[/TD]
[TD]25478544[/TD]
[TD]30/09/2017[/TD]
[TD]30/09/2018
[/TD]
[/TR]
[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[/TABLE]

So far I could get this:

Code:

Public Sub CheckAndSendMail()
    Dim Duedate As Range
    Dim Text As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim DuedateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    Dim i As Long
    On Error Resume Next
    Set Duedate = Range(“D4:D4”)
    If Duedate Is Nothing Then Exit Sub
    Set Text = Range(“A4:A7”)
    If Texto Is Nothing Then Exit Sub
    xLastRow = Duedate.Rows.Count
    Set Duedate = Duedate(1)
    Set Text = Text(1)
    Set xOutApp = CreateObject(“Outlook.Application”)
    For i = 1 To xLastRow
        DuedateVal = Duedate.Offset(i – 1).Value
        If CDate(DuedateVal) – Date  0 Then
            xMailSubject = ” Duedate Ref. ” & Texto.Offset(i – 1).Value
            vbCrLf = “

”
            xMailBody = “”
            xMailBody = xMailBody & “text” & Texto.Offset(i – 1).Value
            xMailBody = xMailBody & ” text” & DuedateVal & “.”
            xMailBody = xMailBody & “”
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = “testexell@outlook.com”
                .HTMLBody = xMailBody
                .Display
                ‘.Send
            End With
            Set xMailItem = Nothing
        End If
    Next
    Set xOutApp = Nothing
End Sub

I know I must somehow be able to extend the range (D4:D4) but it would keep sending emails with the blank cells. And when I rerun the macro the mails would be sent again and again. cant figure how to cut the loop.

Can anyone help me?

Thank you in advance for your time if you read and answer me.

Reply | Quote