Help with Macro Code to send Email using Excel


I have some macro code in an Excel spreadsheet. All the code is working properly except I want it to send individual emails to different recipients each with a different subject. This is based on a date. A recipient might get more than one message but each would have a different subject. My code is sort of working only instead of sending to all the affected recipients, it's only sending it to the first recipient in the column with the same subject but it's sending it multiple times. Below is the code I am using:


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 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
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


3 Replies


Starting multiple discussions with the same question is confusing. See Need Help with Excel Macro 

How would I modify the code you sent me to also include a specific hyperlink to the email that goes out?  It would be a different hyperlink in each email just like the review date is also specific.  Thank you.


It would have been better to ask this in the other discussion...