我想要一个excel文件并创建电子邮件。该文件可能包含多个具有相同电子邮件地址的行。我想为每个唯一地址创建一封电子邮件，并且具有相同地址的行创建一个表格以复制并粘贴到电子邮件中。
我是VBA的新手，但创建了循环Excel文件以创建电子邮件的代码，但是，我需要帮助修改代码，只查看唯一的地址并创建表格。
我现在的代码如下：
Sub SendEmail()
'Uses late binding
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As Range
Dim Subj As String
Dim Rname As String
Dim EmailAddr As String
Dim Rdate As String
Dim Ramount As String
Dim Vendor As String
Dim CHCPName As String
Dim HCPLast As String
Dim Repname As String
Dim Msg As String
'Dim FName As String
'Dim FLoc As String
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*@*" Then
'Get the data
EmailAddr = cell.Value
Subj = "Meals with HCPs"
Repname = cell.Offset(, 1)
Rname = cell.Offset(, 2)
Rdate = cell.Offset(, 3)
Ramount = cell.Offset(, 4).Text
Vendor = cell.Offset(, 5)
CHCPName = cell.Offset(, 6)
'FName = cell.Offset(, 9)
'FLoc = cell.Offset(, 10)
'Compose message
Msg = "Dear " & Repname & ","
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "In a recent review of expense report transactions for Federal Open Payments/Sunshine report, we"
Msg = Msg & " noticed that an incorrect expense type was selected for one or more of your meetings. On the following "
Msg = Msg & "report, you selected an incorrect expense type of " & "<b>Meals w/non HCPs out of office.</b> It appears that there were HCPs present during the meeting(s)."
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "Please make sure that going forward, you select a correct expense type for all meetings with HCPs " & "<b>(Example: Meal w/HCP out Office-Non-Promo).</b>"
Msg = Msg & " We need to ensure that we are reporting correct information. Please note that future violations could result "
Msg = Msg & " in notification to your manager. If you have any questions, please let me know."
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "<b>Expense Report Details:</b>"
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "<b>Report Name: </b>" & Rname
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "<b>Date: </b>" & Rdate
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "<b>Amount: </b>" & Ramount
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "<b>Vendor Name: </b>" & Vendor
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "<b>HCP Name(s): </b>" & CHCPName
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "Regards"
Msg = Msg & "<br/>"
Msg = Msg & "<br/>"
Msg = Msg & "Sunil Kumar"
Msg = Msg & "<br/>"
Msg = Msg & "Manager"
Msg = Msg & "<br/>"
Msg = Msg & "sunil.utleyd@.com"
Msg = Msg & "<br/>"
Msg = Msg & "+1(817)615-2333"
'Create Mail Item and send it
Set MItem = OutlookApp.CreateItem(0) 'olMailItem
With MItem
.to = EmailAddr
.Subject = Subj
.HTMLBody = Msg
'Add Atttachments here if you would like
'.Attachments.Add FLoc & FName
.Save 'to Drafts folder
'.Send does not work due to Macro Security Settings for Alcon. Must send using Outlook
End With
End If
Next
Set OutlookApp = Nothing
End Sub
答案 0 :(得分：0)
如@ K.Davis所示，您可以使用词典或集合来测试重复项。这里我使用ArrayList。
理想情况下，子程序应执行1个任务。您应该将大型子程序分解为执行特定任务的较小子程序。这将使您的代码调试变得更加容易。
Sub SendEmail()
'Uses late binding
Dim list As Object, OutlookApp As Object
Dim cell As Range
Dim HTMLBody As String
'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.value Like "*@*" And Not list.Contains(cell.value) Then
list.Add cell.value
HTMLBody = getMessageBody(cell.Offset(, 1), cell.Offset(, 2), cell.Offset(, 3), cell.Offset(, 4).Text, cell.Offset(, 5), cell.Offset(, 6))
EmailAddr = cell.value
CreateEmail OutlookApp, cell.value, "Meals with HCPs", HTMLBody
End If
Next
Set OutlookApp = Nothing
End Sub
Sub CreateEmail(OutlookApp As Object, EmailAddr As String, Subject As String, HTMLBody As String)
Dim MItem As Object
Set MItem = OutlookApp.CreateItem(0) 'olMailItem
With MItem
.to = EmailAddr
.Subject = Subj
.HTMLBody = Msg
.Save 'to Drafts folder
End With
End Sub
Function getMessageBody(Repname As String, Rname As String, Rdate As String, Ramount As String, Vendor As String, CHCPName As String)
Dim Msg As String
Msg = "Dear " & _
Repname
Msg = Msg & "<br/><br/>" & _
"In a recent review of expense report transactions for Federal Open Payments/Sunshine report, we " & _
"noticed that an incorrect expense type was selected for one or more of your meetings. On the following " & _
"report, you selected an incorrect expense type of " & _
"<b>Meals w/non HCPs out of office.</b> " & _
"It appears that there were HCPs present during the meeting(s)."
Msg = Msg & "<br/><br/>" & _
"Please make sure that going forward, you select a correct expense type for all meetings with HCPs " & _
"<b>(Example: Meal w/HCP out Office-Non-Promo).</b> " & _
"We need to ensure that we are reporting correct information. Please note that future violations could result " & _
"in notification to your manager. If you have any questions, please let me know."
Msg = Msg & "<br/><br/><b>Expense Report Details:</b>" & _
"<br/><br/><b>Report Name: </b>" & _
Rname
Msg = Msg & "<br/><br/><b>Date: </b>" & _
Rdate
Msg = Msg & "<br/><br/><b>Amount: </b>" & _
Ramount
Msg = Msg & "<br/><br/><b>Vendor Name: </b>" & _
Vendor
Msg = Msg & "<br/><br/><b>HCP Name(s): </b>" & _
CHCPName
Msg = Msg & "<br/><br/>Regards<br/><br/>Sunil Kumar<br/>Manager<br/>" & _
"sunil.utleyd@.com<br/>+1(817)615-2333"
getMessageBody = Msg
End Function