Forum Discussion

Diana703's avatar
Diana703
Copper Contributor
Sep 07, 2022

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

Macros and VBA
  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Sep 07, 2022

    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
    • Diana703's avatar
      Diana703
      Copper Contributor
      Sep 07, 2022
      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
      • HansVogelaar's avatar
        HansVogelaar
        MVP
        Sep 07, 2022

        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

Share