See next code and file attached.
Adjust sheet Email Template to your needs
Code
Option Explicit
Sub AnniversaryEmail()
Dim Rg As Range
For Each Rg In Range([F3], Cells(Rows.Count, "F").End(3))
If (Rg.Value = Date) Then
Dim DestEmail As String
Dim CopyEmail As String
Dim WkRg As Range
Dim F
Dim EmailTopic As String
Dim EmailWhat As String
Dim EmailSubject As String
Dim EmailStart1 As String, EmailStart2 As String
Dim EmailEnd1 As String, EmailEnd2 As String
Dim EmailBody As String
Dim FullEmail As String
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
'--- Email info
EmailSubject = Range("EmailSubject")
EmailStart1 = Range("EmailStart1")
EmailStart2 = Range("EmailStart2")
EmailBody = Range("EmailBody")
EmailEnd1 = Range("EmailEnd1")
EmailEnd2 = Range("EmailEnd2")
FullEmail = EmailStart1 _
& Chr(10) & Chr(10) & _
EmailStart2 _
& Chr(10) & Chr(10) & _
EmailBody _
& Chr(10) & Chr(10) & _
EmailEnd1 _
& Chr(10) & Chr(10) & _
EmailEnd2 _
& Chr(10)
'--- People info
DestEmail = Rg.Offset(0, -2)
' CopyEmail = Range("CopyEmail")
'--- Send Email
Application.DisplayAlerts = False
With myItem
If (DestEmail <> "") Then
.To = DestEmail
.CC = CopyEmail
.Subject = EmailSubject
.Body = FullEmail
.Send
End If
End With
Application.DisplayAlerts = True
'--- Close
Set myItem = Nothing
Set myOlApp = Nothing
End If
Next
MsgBox " Job done", , "INFORMATION"
End Sub
Display More