如何遍历列表、查找数据并发送 HTML 电子邮件？

Question

我有以下列表，其中包含针对特定 ID 的一个或多个条目。

我有第二个列表，其中包含唯一 ID 和电子邮件地址。

我需要遍历列表，向每个 ID 发送一封电子邮件，并列出电子邮件中每个匹配行的数据，同时提及总金额。

发送至 ID 1234 foo@的电子邮件示例bar.com:

我目前拥有的：

Sub SendEmail()
    
    Dim strbody1 As String
    Dim strbody2 As String
    Dim Signature As String
    
    Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
    
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
    strbody1 = "Hi,<br><br>" & _
                "Test.<br><br>"
    strbody2 = "Test1.<br><br>" & _
                "Foobar,"
                
    Signature = "<H4><B>My Name</B></H4>" & _
                  "Something<br>" & _
                  "Something<br>" & _
                  "T: +1 000 000 000<br>" & _
                  "<A href=""mailto:foo@bar.com"">foo@bar.com</A><br>" & _
                  "<A HREF=""http://www.bar.com"">www.bar.com</A>"
    
    If MsgBox(("This will send all emails in the list. Do you want to proceed?"), vbYesNo) = vbNo Then Exit Sub
    Set Mail_Object = CreateObject("Outlook.Application")
    For i = 2 To lr
        With Mail_Object.CreateItem(o)
            .Subject = Range("B" & i).Value
            .SentOnBehalfOfName = "foo@bar.com"
            .To = Range("A" & i).Value
            .Body = Range("C" & i).Value
            .HTMLBody = strbody1 & strbody2 & Signature
            .Send 'disable display and enable send to send automatically
        End With
    Next i
    MsgBox "E-mail successfully sent", 64
    Application.DisplayAlerts = False
    Set Mail_Object = Nothing
End Sub

Answer 1

您可以将 ID 放入 Dictionary Object。然后扫描每个 ID 的数据，依次将具有该 ID 的行添加到 html table。如果性能有问题，请先将数据复制到数组并扫描它。

Option Explicit

Sub SendEMail()

    Const WS_ID = "Sheet1"
    Const WS_DATA = "Sheet2"
    Const HEAD = "<head><style>body {font: 20px Verdana;} " & _
                 " .amount {text-align:right;}</style></head>"
    Const TABLE = "<table cellspacing=""0"" cellpadding=""5""" & _
              " border=""1"">" & _
              "<tr bgcolor=""#EEEEEE""><th>REF</th><th>Amount</th></tr>"
    Const TXT = "This is a test email"

    Dim wb As Workbook, ws As Worksheet
    Dim iLastRow As Long, i As Long
    Dim dictID As Object, ID, addr As String

    Set dictID = CreateObject("Scripting.Dictionary")
 
    ' get list of IDS
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(WS_ID)
    iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To iLastRow
        ID = Trim(ws.Cells(i, "A"))
        addr = Trim(ws.Cells(i, "B"))
        If dictID.exists(ID) Then
            MsgBox ID & " is duplicated", vbCritical, "Duplicate ID"
            Exit Sub
        ElseIf InStr(1, addr, "@") > 0 Then
            dictID.Add ID, addr
        End If
    Next

    Dim objOut
    Set objOut = CreateObject("Outlook.Application")

    ' scan data
    Dim total As Double, htm As String
    Set ws = wb.Sheets(WS_DATA)
    iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    For Each ID In dictID
        total = 0
        addr = dictID(ID)
        ' build html table
        htm = "<html>" & HEAD & "<body><p>" & TXT & "</p>" & TABLE
        For i = 2 To iLastRow
            If ws.Cells(i, "A") = CStr(ID) Then
               htm = htm & "<tr><td>" & ws.Cells(i, "B") & _
                     "</td><td class=""amount"">" & ws.Cells(i, "C") & "</td></tr>" & vbCrLf
               total = total + ws.Cells(i, "C")
            End If
        Next
        total = Format(total, "#,##0")
        htm = htm & "<tr bgcolor=""#CCFFCC"" style=""font-weight:bold""><td>TOTAL</td>" & _
              "<td class=""amount"">" & total & "</td></tr></table><br/>" & _
              "<p>The total amount is " & total & "</p></body></html>"
         
        ' send email
        Call SendOneEMail(objOut, CStr(ID), addr, htm)
        
    Next
    MsgBox dictID.Count & " emails sent", vbInformation

End Sub

Sub SendOneEMail(objOut, sID As String, sTo As String, htm As String)
    
    ' create email
    With objOut.CreateItem(0) 'olMailItem
        .Subject = sID
        .SentOnBehalfOfName = "foo@bar.com"
        .To = sTo
        .HTMLBody = htm
        .Display
        '.Send 'disable display and enable send to send automatically
    End With

End Sub

如何遍历列表、查找数据并发送 HTML 电子邮件？

How to loop through list, find data and send in HTML email?

excel

vba

outlook.application