使用VBA向多個收件人發送郵件並複製並粘貼到正文

我想要一個excel文件並創建電子郵件。該文件可能具有多個具有相同電子郵件地址的行。我想爲每個唯一地址創建一封電子郵件，併爲具有相同地址的行創建一個表格以複製並粘貼到電子郵件中。使用VBA向多個收件人發送郵件並複製並粘貼到正文

我是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 & "[email protected]" 
     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

來源

2017-10-19 dutley1

如果唯一改變的是電子郵件，您可以添加列到一個數組或字典來幫助您刪除重複的地址的方式。然後使用'ForArr'中的每個地址來生成電子郵件。 –

正如@ 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/>" & _ 
      "[email protected]<br/>+1(817)615-2333" 
    getMessageBody = Msg 
End Function

來源

2017-10-19 23:32:23

使用VBA向多個收件人發送郵件並複製並粘貼到正文

回答

相關問題