Utilisation de VBA pour envoyer des messages aux destinataires multiples et copier et coller dans le corps

Question

Je veux prendre un fichier Excel et créer des courriels. Le fichier peut comporter plusieurs lignes avec la même adresse e-mail. Je veux créer un e-mail pour chaque adresse unique et pour les lignes qui ont la même adresse créer une table à copier et coller dans l'e-mail. Je suis nouveau à VBA mais j'ai créé du code qui boucle le fichier Excel pour créer des emails, cependant, j'ai besoin d'aide pour modifier le code pour ne regarder que les adresses uniques et créer la table.

Le code que j'ai maintenant ci-dessous:

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 

Answer 1

Comme @ K.Davis indiqué, vous pouvez utiliser un dictionnaire ou une collection pour tester les doublons. Ici, j'utilise une ArrayList.

Idéalement, un sous-programme doit effectuer une tâche. Vous devez décomposer les sous-programmes volumineux en petits sous-programmes qui effectuent des tâches spécifiques. Cela rendra le débogage de votre code beaucoup plus facile.

---

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