如何从 Excel 表格创建电子邮件？答案

【问题标题】：How to create emails from Excel table?如何从 Excel 表格创建电子邮件？
【发布时间】：2021-08-04 14:39:57
【问题描述】：

我在 Excel 中有一个表格。它的构建如下：

|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|

表格中还有一个日期字段。对于测试，这可以设置为今天的日期。

根据这些信息，我正在寻找一个 VBA 代码，它会为每个列出的人准备一封电子邮件，并告诉他们他们在特定日期吃了什么。

我需要访问表中的多个字段，同时循环访问电子邮件地址。然后我希望 VBA 打开 Outlook 并准备电子邮件。最好不要发送它们，这样我可以在发送邮件之前进行最后的查看。

可以通过范围等专门访问某些单元格。我使用的是 Excel/Outlook 2016。

如何在 VBA 中实现这一点？

【问题讨论】：

如果我是正确的，你几个小时前“问”了同样的事情，但删除了。这次也是一样：你没有问任何问题。你试过什么？你被困在哪里了？还是您只是在寻找某人为您编写代码？ SO 不是免费的编码服务，它是关于提出问题并给出答案
@FunThomas 问题是如何在 VBA 中做到这一点，这从文本中显而易见。确实我之前问过这个问题，但有些地方不清楚。现在一切都 100% 清楚了。因此，如果您对此表示反对，请随时解释自己缺少什么。我从未说过 SO 是一种编码服务，但对于有知识的人来说，这可能会在 5 分钟内完成。并且很可能在未来对许多其他人有用
同一个人的表格是否有多行？表格中的日期字段在哪里？
@CDP1802 感谢您的提问。表格中每个人只有一行，例如|Person_A|person_A@mailme.com|3|8|9| 是人员 A 的所有信息。我在表格插图顶部添加了日期字段和标题。

标签： excel vba email outlook

【解决方案1】：

假设数据是一个命名表，并且标题/日期在表的角落上方，如您的示例所示。此外，表的所有行都有有效数据。电子邮件已准备好并显示，但未发送（除非您更改显示的代码）。

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

【讨论】：