Macro that sends email according to a condition

  • Hi All,


    I hope you could accomodate this question, thank you in advance.

    I am trying to write a macro code that will email the recipients based on condition. That is, I have different worksheets in a workbook and each is named according to the report name (except the reports recipients sheet because this serves as reference when emailing recipients).

    If for example my active worksheet is reportname1, and my macro here will open outlook and email recipients, how can I set the recipients to the values on column B of reports recipients sheet while column A is equal to reportname1 (the active sheet)? Note that I would also like to set column C for Cc field and column D on Bcc field while not empty.

    I hope I was able to give clear details, please let me know if otherwise.

    Again, thank you.



  • Hi JessieJoy,

    I'm pretty new to this but I had a similar issue to you previously and managed to work out with the help of the forum a solution that might work for you.

    Set the criteria
    In my example we look for the words 'Electrical' in column E, 'DUE' in column AA, but Column AB doesn't have 'SENT' inserted. This means we need to send an email.

    Then we need to set up the email, subject, body and recipients.

    Hope this helps


  • Hi Mcgee,

    Thank you for helping me. Your code helps me check correponding cells if not empty. However, going back to my first note, I would like to send the email to all reports recipients included in the distrolist instead of hard-coding it, so that when contacts change from time to time, user will just edit the distrolist and not the macro itself.

  • Try this code to build your To and CC strings, I have the emails in each cell starting at row 2 going down on Sheet14

    [VBA]strTO = Join(Application.Transpose(Sheet14.Range(Sheet14.Range("E2"), Sheet14.Range("E2").End(xlDown)).Value), "; ")
    strCC = Join(Application.Transpose(Sheet14.Range(Sheet14.Range("F2"), Sheet14.Range("F2").End(xlDown)).Value), "; ")[/VBA]

    and then with this for the email code

    Dim OutlookApp As Variant
    Dim MItem As Variant
    Dim Msg2 As String, strTO As String, strCC As String

    'Create Mail Item and display it
    Set OutlookApp = CreateObject("Outlook.Application")
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
    .To = strTO
    .CC = strCC
    .Subject = "Remember to do a PEEP/Ergo Observation"
    .HTMLBody = Msg2
    '.Save 'to Drafts folder
    End With[/VBA]

    this isn't my full code just the relevant parts

  • Thanks as well chavezm3. The "Join" worked (part of the code below). Now I have three columns in my "Reports Recipients" worksheet: A: Reports Name (names are same with worksheet names), B: Recipients on To field, C: Recipient on Cc field. I am trying to accomplish looping through column A, so as long as it's same with my active sheet, the To and CC will continue to be copied. Would that be possible with this "Join"? I will post additional code if I have positive results -cross finger :)

    With ActiveWorkbook.Worksheets("Reports Recipients")

    PATo = Join(Application.Transpose(Sheet5.Range(Sheet5.Range("B2"), Sheet5.Range("B2").End(xlDown)).Value), "; ")
    PACc = Join(Application.Transpose(Sheet5.Range(Sheet5.Range("C2"), Sheet5.Range("C2").End(xlDown)).Value), "; ")

    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
    .To = PATo
    .CC = PACc
    .Subject = "My Report" & Format(Now(), "MMMM YYYY")
    .htmlbody = HTMLBody
    strLocation = ThisWorkbook.Path & "" & sFilename & UCase(Format(Now(), "YYYY-MMM-DD")) & ".xlsx"
    .Attachments.Add (strLocation)
    End With

    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing