VBA 从 Excel 发送电子邮件

Question

I have a simple 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. So I need to access several fields in the table, and at the same time loop through the emails. Then I would like VBA to open Outlook and prepare the Emails. Ideally not send them yet, 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 if that matters. The question is how this can 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