Visual basic code for email reminders

[JonDoe4567]

Hello guys,

How can I make excel send email reminders in outlook based on the given dates In one column. I would like to make it send the reminder with 6 months in advance, do you have any ideas?

I have seen it is possible to do so with visual basic but I do not know how to code.

 

[Micron]

No time like the present to learn some coding. You will first need to decide on what will trigger the email. Userform button? Sheet button? Simply opening the workbook? Changing a specific cell?
Find a code example that is close to what you want (there will likely be literally millions of hits for this) then copy and paste it into a new module. It should provide a means for looping over your sheet rows to check the dates and pull the email address (from the same row I guess). Assuming that the first date is in A2, your code version would decide to create an email based on something like this:

If Datediff("d",Date(),sheets("7").range("A2")) <=180 Then
   create and send email code here
End If

Note that you will need to consider how to deal with the recipients you sent email to. If you don't flag this somehow, every time you cause the code to run they will receive another one. A column (E in the following example) with the date that the message was sent is the way I'd probably go. Then the logical test becomes

If Datediff("d",Date(),sheets("7").range("A2")) <=180 AND IsEmpty sheets("7").range("E2") Then

 

[ranman256]

paste this code into a module. Then you would run: FindMyDates
it will look for records on the exact 6 months date

you will need to alter the column values for: kColDTE & kColEMAIL
in my example:
the date value is column offset = 4 (actual is col 5)
the email value is column offset = 5 (actual is col 6)

it will then scan the data look at the date is = the 6 mo date, then flag it.
then it sends the email ,via: Send1Email vEmail, vSubj, vbody
so adjust your param values for:
subject & vBody

'---------------------
Sub FindMyDates()
'---------------------
Dim iRows As Long, iFldNum As Long, iResultOFF As Long
Dim vTxt, vEmail, vBody
Dim sResultCol As String
Dim i As Integer
Dim vDate2Find As Date

Const kResultHdr = "Results"
Const kFOUND = "found"
Const kColDTE = 4   'offset val, aka col.5
Const kColEMAIL = 5  'offset val aka col.6

vBody = "This is the body of the email"

  'load the legal search values
vDate2Find = get6MoDate()

  'add a result column
Sheets("data").Activate
Range("A1").Select
Selection.End(xlToRight).Select
If InStr(ActiveCell.Value, kResultHdr) = 0 Then
   ActiveCell.Offset(0, 1).Select
   ActiveCell.Value = kResultHdr
End If
iFldNum = ActiveCell.Column
iResultOFF = iFldNum - Range("A1").Column
sResultCol = iFldNum & ":" & iFldNum

sResultCol = getMyColLtr()
  'clear results col.
Columns(iFldNum).ClearContents
Range(sResultCol & "1").Value = kResultHdr

  'get #rows
Range("A1").Select
iRows = ActiveSheet.UsedRange.Rows.Count

'MsgBox iRows
Range("A2").Select
While ActiveCell.Row <= iRows
   vTxt = ActiveCell.Offset(0, kColDTE).Value
    If CDate(vTxt) = vDate2Find Then
        ActiveCell.Offset(0, iResultOFF).Value = kFOUND
        vEmail = ActiveCell.Offset(0, kColEMAIL).Value
      
          'Debug.Print vEmail
        Send1Email vEmail, "Your acct", vBody
    End If
 
   ActiveCell.Offset(1, 0).Select 'next row
Wend

 'filter results
ActiveSheet.Range("A1").AutoFilter Field:=iFldNum, Criteria1:=kFOUND

  'copy the results
'SaveFoundData
End Sub

'---------------------
Public Function getMyColLtr()
'---------------------
Dim vRet
Dim i As Integer
vRet = Mid(ActiveCell.Address, 2)
i = InStr(vRet, "$")
If i > 0 Then vRet = Left(vRet, i - 1)
getMyColLtr = vRet
End Function

'---------------------
private Sub SaveFoundData()
'---------------------
Range("A1").Select
ActiveSheet.UsedRange.Select
     'Range("A1:G27").Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
  
    ActiveWorkbook.SaveAs Filename:="C:\TEMP\found data.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub



Public Function get6MoDate()
get6MoDate = DateAdd("m", -6, Date)
End Function


Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem

On Error GoTo ErrMail

'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library

Set oApp = GetApplication("Outlook.Application")  'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application")  'not this

Set oMail = oApp.CreateItem(olMailItem)
With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
  
    .HTMLBody = pvBody
    'If Not IsNull(pvBody) Then .Body = pvBody
  
    .Display True   'show user but dont send yet
    '.Send          'send now
End With

Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
'DoCmd.OutputTo acOutputReport, "rMyReport", acFormatPDF, vFile

End Function

Private Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
    MsgBox "Unable to Get" & className & ", attempting to CreateObject"
    Set theApp = CreateObject(className)
End If

If theApp Is Nothing Then
    Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
    Set GetApplication = Nothing
End If

'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function

 

[JonDoe4567]

Thank you both for your knowledge!

I will give it a try and try to learn the coding myself.