Forum Discussion
Need Help with Excel Macro
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
See the attached version. The code is in Module1.
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- 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 SubThe 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
