ient. however, all I am getting in the same recipient and same subject shown three times (although the date is correct in the email body). I've tried and tried but can't get it to work.I need my vba to create individual emails for each recipient in a column. There might be more than one email for the same recipient and some recipients might not have any email because it is based on a date. I also need it to show the individual subject associated with that respective recipient. Thank you. Please, please help!
Here is my code:
Sub Macro1()
Dim rngCell As Range
Dim rngMyDataSet As Range
Dim Rng As Range
Dim OutApp As Object
Dim objOutlook As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim sTo As String
Dim MailBody As Range
Dim EmailRecipient As String
Dim Signature As String
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range("AH5", .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each rngCell In Rng
If rngCell.Offset(0, 6) > 0 Then
ElseIf rngCell.Offset(0, 5) > Evaluate("Today() -7") And _
rngCell.Offset(0, 5).Value <= Evaluate("Today() +120") Then
rngCell.Offset(0, 6).Value = Date
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "According to my records, your " & Range("A5").Value & " contract is due for review " & rngCell.Offset(0, 5).Value & _
". It is important you review this contract ASAP and email me with any changes made." _
& vbNewLine & "If this contract is renewed or rolled over, please fill out the Contract Cover Sheet which can be found in the Everyone folder and send me the cover sheet along with the new original contract."
EmailSendTo = Sheets("sheet1").Range("AH5").Value
EmailSubject = Sheets("sheet1").Range("A5").Value
Signature = "C:\Documents and Settings\" & Environ("rmm") & _
"\Application Data\Microsoft\Signatures\rm.htm"
On Error Resume Next
With OutMail
.To = EmailSendTo
.CC = "email address removed for privacy reasons"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Display
Send_Value = Mail_Recipient.Offset(i - 1).Value
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next rngCell
Application.ScreenUpdating = True
End Sub
