Use VBA to send a Outlook Email to myself When within 2 weeks of deadline

[Andrew oren]

Project Description I need a spreadsheet which has some Visual Basic functionality programmed in.
The spreadsheet will have the following column headers.

Name, ID #, Date of Birth, Age, Gender, Review Date, Outcome, Outcome ID#, Distance, Stage 1 Date, Stage 2 Date, Stage 3 Date, Mailed, Called, Dx, Reason, Location, Comments.

The spreadsheet should also have a macro button on top of spreadsheet which says "Send Reminder Emails." I'd like the button to activate a VB script which reviews the dates in the "Stage 2 Date, and Stage 3 Date" columns. When the date in either column comes within 2 weeks I'd like the script to generate a reminder email to my outlook email. The email subject line should be, "2-Week Appointments - Review Required."

The email should contain an easily readable reminder which contains all of the data elements in the row (with the appropriate column headers above). The reminder should state, "Please review the following accounts for upcoming eligibility." The data elements can be in table form or free-text, whichever looks the most readable/user-friendly.

I specifically want this macro/VB script to only run if I manually press the macro button on the top. I do not want it to generate upon opening the file.

 

[Jigar B]

Please attach the worksheet with sample data in it.
Also please specify you need to send only one email with body containing all such row or you need one email for each such row?

 

[Jigar B]

Please find the attached file containing button and VBA code. Also need to change the email ID in line StrEmailAddress = "emailID@domain.com" in following code:

Option Explicit

Sub Button1_Click()
    Dim rng As Range
    Dim OutApp, OutMail As Object
    Dim LastRow, i, Filtred_Rows_Count As Long
    Dim StrEmailAddress, StrSubject As String
   
    StrEmailAddress = "emailID@domain.com"
    StrSubject = "2-Week Appointments - Review Required"
   
    Sheets("Sheet1").Select
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("S2").Value = "Send Email"
    For i = 3 To LastRow
        If Range("J" & i).Value > Date And Range("J" & i).Value < Date + 15 Then
            Cells(i, "J").Interior.ColorIndex = 37
            Cells(i, "S").Value = "Yes"
        End If
        If Range("K" & i).Value > Date And Range("K" & i).Value < Date + 15 Then
            Cells(i, "K").Interior.ColorIndex = 37
            Cells(i, "S").Value = "Yes"
        End If
    Next
   
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    ActiveSheet.Range("A2:S" & LastRow).AutoFilter Field:=19, Criteria1:="Yes"
    Filtred_Rows_Count = Application.Subtotal(3, Columns("A")) - 1
   
    If Filtred_Rows_Count > 0 Then
            Range("A2:R" & LastRow).Select
            Set rng = Selection.SpecialCells(xlCellTypeVisible)
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = StrEmailAddress
                .CC = ""
                .BCC = ""
                .Subject = StrSubject
                .HTMLBody = RangetoHTML(rng)
                '.Display
                .Send
            End With
            Set OutMail = Nothing
            Set OutApp = Nothing
        Else
            MsgBox ("No Appointments found!!")
        End If
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Columns("S:S").Delete
    Range("J3:K" & LastRow).Interior.ColorIndex = 0
    Range("A2").Select
    Set rng = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function