CODEWITHSUNDEEP
excelvbaemailoutlook
EtoAls
EtoAls

Reputation: 125

How to create emails from Excel table?

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|[email protected]|3|8|9|
|Person_B|[email protected]|10|59|11|
|Person _C|[email protected]|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?

Upvotes: 0

Views: 363

Answers (1)

CDP1802
CDP1802

Reputation: 16332

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 protected]"
            .Subject = sTitle
            .HTMLBody = ar(2)
            .display ' or .send
        End With
    Next
    oApp.Quit
    
End Sub

Upvotes: 1

Related Questions