Need Help with Excel Macro

[Diana703]

I have a large excel sheet (macro enabled) that I want to send email from with specific data in each email.  I have all working right but I can't get it to create an email to send to each email address with that email address' specific SUBJECT.  My macro runs but puts the same email address in the TO and the same subject in the SUBJECT in each email.  FYI - my macro also puts in a date that the email was sent.  You'll need to delete this date each time you run the macro or it won't run.

I'm about ready to give up...will someone please help me??  Here is the code I'm using.  I've also attached the spreadsheet.

Sub Macro1()
Dim mApp As Object
Dim rngCell As Range
Dim rngMyDataSet As Range
Dim Rng As Range
Dim OutApp As Object
Dim mMail As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim SendToMail As String
Dim EmailRecipient As Range
Dim Signature As String

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. If it is renewed, 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."
SendToMail = 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
For Each r In Selection
SendToMail = Range("AH" & r.Row)
MailSubject = Range("A" & r.Row)
mMailBody = Range("AO" & r.Row)
Set mApp = CreateObject("Outlook.Application")
Set mMail = mApp.CreateItem(0)
With mMail
.To = SendToMail
.Subject = MailSubject
.Body = mMailBody
.Display ' You can use .Send
End With
Next r
Application.ScreenUpdating = False

End If

Next rngCell
Application.ScreenUpdating = True
End Sub

[#2]

@Diana703 

You have intermingled two pieces of code. Try this:

Sub Macro1()
    Dim rngCell As Range
    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strBody As String
    Dim mMailBody As String
    Dim EmailSubject As String
    Dim SendToMail As String
    'Dim Signature As String
    Dim r As Long
    With ActiveSheet
        If .FilterMode Then .ShowAllData
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set Rng = Range("AH5", Cells(Rows.Count, "AH").End(xlUp))
    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
            r = rngCell.Row
            rngCell.Offset(0, 6).Value = Date
            Set OutMail = OutApp.CreateItem(0)
            ' Which of these do you want to use? strBody or mMailBody?
            ' ***
            strBody = "According to my records, your " & Range("A" & r).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. If it is renewed, 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."
            mMailBody = Range("AO" & r).Value
            ' ***
            SendToMail = Range("AH" & r).Value
            EmailSubject = Range("A" & r).Value
            'Signature = "C:\Documents and Settings\" & Environ("rmm") & _
                "\Application Data\Microsoft\Signatures\rm.htm"
            On Error Resume Next
            With OutMail
                .To = SendToMail
                .Subject = EmailSubject
                .Body = mMailBody ' or strBody
            .Display ' You can use .Send
            End With
            Application.ScreenUpdating = False
        End If
    Next rngCell
    Application.ScreenUpdating = True
End Sub

[#3]

Thank you for such a fast reply. This is the code I used but it did absolutely nothing. Didn't even put in my automatic email sent dates. What did I do wrong?

Sub Macro1()
Dim rngCell As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim EmailSubject As String
Dim SendToMail As String
'Dim Signature As String
Dim r As Long
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Set OutApp = CreateObject("Outlook.Application")
Set Rng = Range("AH5", Cells(Rows.Count, "AH").End(xlUp))
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
r = rngCell.Row
rngCell.Offset(0, 6).Value = Date
Set OutMail = OutApp.CreateItem(0)
strBody = "According to my records, your " & Range("A" & r).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. If it is renewed, 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."
SendToMail = Range("AH" & r).Value
EmailSubject = Range("A" & r).Value
'Signature = "C:\Documents and Settings\" & Environ("rmm") & _
"\Application Data\Microsoft\Signatures\rm.htm"
On Error Resume Next
With OutMail
.To = SendToMail
.Subject = EmailSubject
.Body = strBody
.Display ' You can use .Send
End With
Application.ScreenUpdating = False
End If
Next rngCell
Application.ScreenUpdating = True
End Sub

[#4]

@Diana703 

The code doesn't create any email messages since none of the rows satisfy the conditions in

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

[#5]

The only thing I need it to do yet is to send out the emails to the individual recipients. It does create three emails but they are all going to the same person. Can you help me with this? Thank you.

[#6]

@Diana703 

I temporarily commented out the criteria, since they don't work, and don't make any sense to me. I got these three messages. Three different recipients, three different subjects, and (not shown) three different message texts. So the problem must lie elsewhere.

[#7]

Thank you so much for continuing to help me. I'm not sure what you mean by " commented out the criteria"...what is the criteria? I'll take it out on my end if you tell me what it is and see if I get the same thing.

[#8]

@Diana703 

I meant the lines

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

and the corresponding End If.

[#9]

Those particular lines of code put in my email date that the emails are sent. I took them out and my spreadsheet went wild. Kept on producing emails. I still have to delete them but I'm guessing it produced about 100 emails, all to the same recipient and it filled in all the black cells in the first three lines of my spreadsheet data with todays date.

[#10]

@Diana703 

I'm afraid I can't explain that.

[#11]

I just thought it was the oddest thing I've ever seen Excel do!

[#12]

Can you send me the code you used to get the above? I tried editing mine and it didn't work. Thank you.

[#13 · Accepted solution]

@Diana703 

See the attached version. The code is in Module1.

[#14]

Oh my gosh! This is working. I think I love you for being so patient with me and helping me with this. I could cry! Thank you, thank you, thank you!

[#15]

Gosh, you are going to wish you'd never heard of me but there is one thing that it has stopped doing. It used to put the date when the emails were sent in the Email Sent column but now it's not doing that. Can you fix that part of the code yet and then I promise to leave you alone. Thank you!

[#16]

@Diana703 

Try this version. You can also try uncommenting the If ... and End If lines - I think they should work correctly now.

Sub Button1_Click()
    Dim rngCell As Range
    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strBody As String
    Dim EmailSubject As String
    Dim SendToMail As String
    Dim r As Long
    With ActiveSheet
        If .FilterMode Then .ShowAllData
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set Rng = Range("AH5", Cells(Rows.Count, "AH").End(xlUp))
    For Each rngCell In Rng
        'If Range("P" & r).Value = "" And _
                Range("O" & r).Value > Date + 7 And _
                Range("O" & r).Value <= Date + 120 Then
            r = rngCell.Row
            Range("P" & r).Value = Date
            Set OutMail = OutApp.CreateItem(0)
            strBody = "According to my records, your " & Range("A" & r).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. If it is renewed, 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."
            SendToMail = Range("AH" & r).Value
            EmailSubject = Range("A" & r).Value
            On Error Resume Next
            With OutMail
                .To = SendToMail
                .Subject = EmailSubject
                .Body = strBody
            .Display ' You can use .Send
            End With
            Application.ScreenUpdating = False
        'End If
    Next rngCell
    Application.ScreenUpdating = True
End Sub

[#17]

You are the MASTER! I can't thank you enough! God bless you!

[#18]

@Diana703 

In another discussion, you asked

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.

If you include a URL complete with https:// or http:// in the body text of the email message, Outlook will automatically convert it to a hyperlink. The URL can come from the value of a cell, just like you get the type of contract from a cell.