How to create emails from Excel table? - excel

Question

I have a table in Excel. It is built as follows:
|Information on food|
|date: April 28th, 2021|
|Person|Email|Apples|Bananas|Bread|
|------|-----|------|-------|-----|
|Person_A|person_A#mailme.com|3|8|9|
|Person_B|person_B#mailme.com|10|59|11|
|Person _C|person_C#maime.com|98|12|20|
There is also a date field in the table. For a test, this could be set to todays date.
Based on this information, I am looking for a VBA code which prepares an email to each of the listed persons and is telling them what they have eaten on the specific date.
I need to access several fields in the table, and at the same time loop through the email addresses. Then I would like VBA to open Outlook and prepare the emails. Ideally not send them so I can take a final look before I send the mails.
It would be fine to access certain cells specifically via ranges etc. I am using Excel/Outlook 2016.
How can this be achieved in VBA?

Answer 1

Assuming the data is a named table and title/date are above the corner of the table as shown in your example. Also all the rows of the table have valid data. The emails are prepared and shown but not sent (unless you change the code where shown).
Option Explicit
Sub EmailMenu()
Const TBL_NAME = "Table1"
Const CSS = "body{font:12px Verdana};h1{font:14px Verdana Bold};"
Dim emails As Object, k
Set emails = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet, rng As Range
Dim sName As String, sAddress As String
Dim r As Long, c As Integer, s As String, msg As String
Dim sTitle As String, sDate As String
Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.ListObjects(TBL_NAME).Range
sTitle = rng.Cells(-1, 1)
sDate = rng.Cells(0, 1)
' prepare emails
For r = 2 To rng.Rows.Count
sName = rng.Cells(r, 1)
sAddress = rng.Cells(r, 2)
If InStr(sAddress, "#") = 0 Then
MsgBox "Invalid Email: '" & sAddress & "'", vbCritical, "Error Row " & r
Exit Sub
End If
s = "<style>" & CSS & "</style><h1>" & sDate & "<br>" & sName & "</h1>"
s = s & "<table border=""1"" cellspacing=""0"" cellpadding=""5"">" & _
"<tr bgcolor=""#ddddff""><th>Item</th><th>Qu.</th></tr>"
For c = 3 To rng.Columns.Count
s = s & "<tr><td>" & rng.Cells(1, c) & _
"</td><td>" & rng.Cells(r, c) & _
"</td></tr>" & vbCrLf
Next
s = s & "</table>"
' add to dictonary
emails.Add sAddress, Array(sName, sDate, s)
Next
' confirm
msg = "Do you want to send " & emails.Count & " emails ?"
If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
' send emails
Dim oApp As Object, oMail As Object, ar
Set oApp = CreateObject("Outlook.Application")
For Each k In emails.keys
ar = emails(k)
Set oMail = oApp.CreateItem(0)
With oMail
.To = CStr(k)
'.CC = "email#test.com"
.Subject = sTitle
.HTMLBody = ar(2)
.display ' or .send
End With
Next
oApp.Quit
End Sub