如何從 Excel 表格創建電子郵件？ (How to create emails from Excel table?)

問題描述

如何從 Excel 表格創建電子郵件？ (How to create emails from Excel table?)

我在 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 中實現這一點？

參考解法

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

(by EtoAls、CDP1802)

參考文件

1. How to create emails from Excel table? (CC BY‑SA 2.5/3.0/4.0)