如何解决VBA - 循环遍历列表，查找数据并以 html 电子邮件发送
我需要遍历列表，向每个 ID 发送一封电子邮件，并列出电子邮件中每个匹配行的数据，并提及总金额。我知道如何使用 VBA 发送 html 电子邮件，但我不确定如何使其工作。
这将是发送到 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
解决方法
您可以将 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),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
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。