Generate Emails with Excel VBA by looping through sheets

[QMAN223]

Hi,

I have 20 sheets which have Emails in a Table. (See image below which describes how the table is set up)

Currently, in each sheet, I have a Macro Button that generates the email. I have to manually go into each sheet in the file and generate the email.

I want to create a loop, where if I click one button, all the emails are subsequently generated for each sheet.

Option Explicit
Sub Send_Email_With_Attachment()
    Dim OutApp As Object, OutMail As Object
    Dim emailTo As String, emailCC As String
    Dim lastSunday As Date
    Dim c As Range
    
    lastSunday = DateAdd("d", 1 - Weekday(Now), Now)
    
    emailTo = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Email2[To]"))
    emailCC = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Email2[CC]"))
     
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = emailTo
            .CC = emailCC
            .Subject = "Training Report  - " & Format(lastSunday, "dd-MM-yyyy")
            .Body = "Dear All" & vbCrLf & vbCrLf & _
            "Please find attached the Weekly Training report." & vbCrLf & vbCrLf & "Kind Regards,"
            '.Attachments.Add ""
            .Send
        End With

End Sub

 

[JEC]

Like this, if every sheet contains a table. Otherwise you have to use some criteria in your loop

Sub jec()
 For Each sh In ThisWorkbook.Sheets
   With CreateObject("Outlook.Application").CreateItem(0)
    .To = Join(Application.Transpose(sh.ListObjects(1).DataBodyRange.Columns(1)), ";")
    .CC = Join(Application.Transpose(sh.ListObjects(1).DataBodyRange.Columns(2)), ";")
    .Subject = "Training Report  - " & Format(DateAdd("d", 1 - Weekday(Now), Now), "dd-MM-yyyy")
    .Body = "Dear All" & vbCrLf & vbCrLf & "Please find attached the Weekly Training report." & vbCrLf & vbCrLf & "Kind Regards,"
    '.Attachments.Add
    .display '.send
   End With
 Next
End Sub

 

[QMAN223]

Hi Jec,

Thanks for replying.

I forgot to mention that each sheet has a unique email subject & body text. How would I go about looping for this scenario?
I think this will make the code more complicated but far more efficient.

Also, can I ask, how do I add a 'Check Names' method inside the code I provided so it checks if the people who I'm sending the email to exists in the address book? I have searched everywhere and I can't seem to find a solution for this.

Thank you in advance!

 

[JEC]

To create unique subjects and body texts, you need to specify your text in the individual sheets (Use the same ranges in every sheet).
Then refer to these ranges in the code.

 

[JEC]

If you run this first to create a list of your addressbook. ("Global Address List" could have a different name like "contacts")

Sub jec()
 Dim ar(), it As Variant, x As Long
 For Each it In CreateObject("outlook.application").session.addresslists("Global Address List").addressentries
   ReDim Preserve ar(x)
   ar(x) = it.Address: x = x + 1
 Next
 Sheets(1).Cells(1, 10).Resize(x) = Application.Transpose(ar)
End Sub

Then run the code below

Sub jecc()
 For Each sh In ThisWorkbook.Sheets
   For Each it In sh.ListObjects(1).DataBodyRange
      a = Application.Match(it, Sheets(1).Cells(1, 10).CurrentRegion, 0)
      If Not IsNumeric(a) Then MsgBox it & " does not exist in the addressbook, prompt cancelled", vbOKOnly, "attention": Exit Sub
   Next
   With CreateObject("Outlook.Application").CreateItem(0)
    .To = Join(Application.Transpose(sh.ListObjects(1).DataBodyRange.Columns(1)), ";")
    .CC = Join(Application.Transpose(sh.ListObjects(1).DataBodyRange.Columns(2)), ";")
    .Subject = "Training Report  - " & Format(DateAdd("d", 1 - Weekday(Now), Now), "dd-MM-yyyy")            'for example: sh.range("A10").value   (where the subject text is)
    .Body = "Dear All" & vbCrLf & vbCrLf & "Please find attached the Weekly Training report." & vbCrLf & vbCrLf & "Kind Regards,"    'for example: sh.range("A11").value   (where the body text is)
    '.Attachments.Add
    .display '.send
   End With
 Next
End Sub

 

[QMAN223]

If you run this first to create a list of your addressbook. ("Global Address List" could have a different name like "contacts")

Sub jec()
 Dim ar(), it As Variant, x As Long
 For Each it In CreateObject("outlook.application").session.addresslists("Global Address List").addressentries
   ReDim Preserve ar(x)
   ar(x) = it.Address: x = x + 1
 Next
 Sheets(1).Cells(1, 10).Resize(x) = Application.Transpose(ar)
End Sub

Then run the code below

Sub jecc()
 For Each sh In ThisWorkbook.Sheets
   For Each it In sh.ListObjects(1).DataBodyRange
      a = Application.Match(it, Sheets(1).Cells(1, 10).CurrentRegion, 0)
      If Not IsNumeric(a) Then MsgBox it & " does not exist in the addressbook, prompt cancelled", vbOKOnly, "attention": Exit Sub
   Next
   With CreateObject("Outlook.Application").CreateItem(0)
    .To = Join(Application.Transpose(sh.ListObjects(1).DataBodyRange.Columns(1)), ";")
    .CC = Join(Application.Transpose(sh.ListObjects(1).DataBodyRange.Columns(2)), ";")
    .Subject = "Training Report  - " & Format(DateAdd("d", 1 - Weekday(Now), Now), "dd-MM-yyyy")            'for example: sh.range("A10").value   (where the subject text is)
    .Body = "Dear All" & vbCrLf & vbCrLf & "Please find attached the Weekly Training report." & vbCrLf & vbCrLf & "Kind Regards,"    'for example: sh.range("A11").value   (where the body text is)
    '.Attachments.Add
    .display '.send
   End With
 Next
End Sub

Hi JEC,

Thanks for replying.

Ahhh, so the first code will add emails to an address book? I don't actually want that. I want the Macro to click on this icon after the email has been generated... Please see the Image below. Is there a way for the macro to click on that button after the emails have been put in the To and CC section?

Awesome! Thanks for the loop code! I really appreciate it

 

[QMAN223]

Hi JEC,

I used this code you provided and it works amazing!

The only issue I have is it creates an email for each sheet name. I don't want to create an email with all the sheet names.....

Cheers!

 

[JEC]

The first code just generates a list of all existing emails in your addressbook. Then pastes that into a sheet.
After you run that code, the second code (generating emails) checks if the email addresses are actually in your list. If so, it sends the email.

If you could explain your last issue a little better, I can look at that

 

[QMAN223]

The first code just generates a list of all existing emails in your addressbook. Then pastes that into a sheet.
After you run that code, the second code (generating emails) checks if the email addresses are actually in your list. If so, it sends the email.

If you could explain your last issue a little better, I can look at that

Oh I see, makes more sense!

Sure. please see the image...

When I run the macro, it create an email with all the sheet names as the picture below... I don't want the Macro to do that. The rest works perfectly!

 

[JEC]

Could there be a table with all sheetnames in it?
The code always looks at .listobjects(1), considering every sheet has just 1 table