时间戳

首页 > 解决方案 > 如何遍历列表、查找数据并在 HTML 电子邮件中发送？

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

问题描述

我有以下列表，其中包含一个或多个特定 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

标签： excelvbaoutlook.application

解决方案

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

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

推荐阅读