Send Emails from Excel with Dynamic Range Selection

[ridikulus]

Hi there,

I am very new to the VBA world so please excuse my pace in understanding your brilliant responses.

The task at hand involves sending weekly emails to 4 different sets of recipients. With each set of recipients, they will receive a table of data in the body of the email that is relevant to them. The table of data in my worksheet is dynamic with respects to the number of rows it includes on a weekly basis.

I put together a code that allowed me to get far enough into automating the emailing process but I am now stuck at the stage where I have to select/copy/paste the dynamic data range to include in the body of the email. In my code below, I set up "ca11_table" and "ca12_table" as strings (they are the dynamic data ranges) and I want to include them as part of my "mail_body_message" which is cell K2 that includes the text of the email. ca11_table and ca12_table would be located in a different worksheet.

Thanks in advance for your support!




Sub SENDEMAILS(what_address As String, what_cc As String, what_bcc As String, subject_line As String, mail_body As String)


Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")


Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)

olMail.To = what_address
olMail.CC = what_cc
olMail.BCC = what_bcc
olMail.Subject = subject_line
olMail.BodyFormat = olFormatHTML
olMail.HTMLBody = mail_body
olMail.Display


End Sub


Sub Sendmassemail()


row_number = 1


Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim ca11_table As String
Dim ca12_table As String

mail_body_message = Sheet1.Range("K2")
full_name = Sheet1.Range("D" & row_number) & " " & Sheet1.Range("E" & row_number)
mail_body_message = Replace(mail_body_message, "replace_name_here", full_name)
Call SENDEMAILS(Sheet1.Range("A" & row_number), Sheet1.Range("B" & row_number), Sheet1.Range("C" & row_number), "Weekly Email Subjectline", mail_body_message)

Loop Until row_number = 10


End Sub

[ridikulus]

So I was able to figure out a way to bring in the ca11_table and ca12_table into the body of the email using Functions but now my issue is formatting. My current code brings in all the text in what appears to be a default font and size, even so for the tables (no borders or formatting from the Excel sheet). How do I go about changing my current code in order to bring in the same formatting in the body of the email? I am most concerned with including the formatting of the tables from Excel: borders and colours.

Current code:

Sub GenerateEmails(what_address As String, what_cc As String, what_bcc As String, subject_line As String, mail_body As String)


Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")


Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)

olMail.To = what_address
olMail.CC = what_cc
olMail.BCC = what_bcc
olMail.Subject = subject_line
olMail.BodyFormat = olFormatHTML
olMail.HTMLBody = mail_body
olMail.Display


End Sub




Function GetCA11Data() As String


Dim CA11Column As Range, CA11Row As Range, r As Range, c As Range
Dim str As String

Sheet11.Activate
Set CA11Column = Range("B1", Range("B1").End(xlDown))

str = "<table>"

For Each r In CA11Column

str = str & "<tr>"

Set CA11Row = Range(r, r.End(xlToRight))
For Each c In CA11Row

str = str & "<td>" & c.Value & "</td>"

Next c

str = str & "</tr>"

Next r

str = str & "</table>"

GetCA11Data = str


End Function


Function GetCA12Data() As String


Dim CA12Column As Range, CA12Row As Range, r As Range, c As Range
Dim str As String

Sheet11.Activate
Set CA12Column = Range("S1", Range("S1").End(xlDown))

str = "<table>"

For Each r In CA12Column

str = str & "<tr>"

Set CA12Row = Range(r, r.End(xlToRight))
For Each c In CA12Row

str = str & "<td>" & c.Value & "</td>"

Next c

str = str & "</tr>"

Next r

str = str & "</table>"

GetCA12Data = str


End Function


Sub GenerateMassEmails()


row_number = 1


Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_subject As String

mail_body_message = Sheet1.Range("K2")
full_subject = Sheet1.Range("D" & row_number) & " POs as of " & Sheet1.Range("E" & row_number)
mail_body_message = Replace(mail_body_message, "ca11_table_replace", GetCA11Data)
mail_body_message = Replace(mail_body_message, "ca12_table_replace", GetCA12Data)
Call GenerateEmails(Sheet1.Range("A" & row_number), Sheet1.Range("B" & row_number), Sheet1.Range("C" & row_number), full_subject, mail_body_message)

Loop Until row_number = 2


End Sub