XL 2019 Macro - Envoyer des mails depuis un tableau de données

[Bas699]

Bonjour tout le monde,

Dans le cadre de mon travail, je désire faire une macro pour envoyer des mails indiquant à différentes personnes qu'ils ont des documents à aller signer.

L'idée est d'envoyer un mail unique regroupant tous les noms de docs + liens vers les documents à la personne en question puis de passer à la suivante et ainsi de suite jusqu'à la dernière ligne du tableau.
Pour grouper les mails, j'ai pensé à une boucle while mais je ne sais pas comment indiquer de passer à la personne suivante ... J'ai tenté différentes boucles mais sans succè : si vous pouviez m'aider svp.

Je vous joins le tableur, ça regroupe bien les 4 docs + lien à "User 1" mais je n'ai pas réussi à agrandir la boucle aux autres users du tableau ...

J'espère avoir été clair sur mon problème, sinon n'hésitez pas à me le signaler. Je vous mets le code ci-dessous :

Sub Envoi_mail_ter() 'début du programme
Dim OutApp As Object 'Déclaration de l'application objet Outlook
Dim OutMail As Object 'Déclaration du mail objet Outlook
Dim ligne As Integer
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim i As Long
Dim j As Long
Dim adresse As String
Dim corpsmail As String
Dim Lien_Hyper As Variant


    With OutMail 'début de la boucle
     i = 2
        adresse = Worksheets("Données PW").Range("c" & i)
       While Worksheets("Données PW").Range("c" & i) = adresse
       Lien_Hyper = Worksheets("Données PW").Range("j" & i)
               corpsmail = corpsmail & "<p>" & "Vous avez un document dont la livraison est prévue pour le " & Worksheets("Données PW").Range("d" & i) & "<p>" & Worksheets("Données PW").Range("a" & i) & "<p>" & "<a href = '" & Lien_Hyper & "'>Lien_PW</a>"
               i = i + 1

    .To = adresse  'champ envoyer à
                                         'ne pas oublier les "" lorsque le texte est écrit 'en dur'
                                         'séparer les adresses mail par un ;
    .CC = "doc.user@g.com" 'champ mail en copie
    .BCC = "" 'champ mail en copie caché
    .Subject = Worksheets("Mail").Range("B3")  'champ du sujet du mail
    .htmlbody = "Bonjour, " & "<p>" & corpsmail & "<p>" & "<p>" & "Cordialement ," & "<p>" & "<p>" & "L'équipe Doc Control"
            'champ du corps du mail
            ' ajouter & vbCrlF & pour aller à la ligne entre deux valeurs

    .Display ligne 'affiche le mail en brouillon dans Outlook, pratique
             'pour vérifier avant d'envoyer
    '.Send 'envoie directement le mail
    '.Save 'sauvegarde le mail
    
           Wend
      End With 'fin de la boucle

Set OutMail = Nothing 'nettoie la mémoire en nettoyant les variables
Set OutApp = Nothing 'nettoie la mémoire en nettoyant les variables
End Sub 'fin du programme

Merci d'avance.
Cordialement.

 

[AtTheOne]

Bonjour à toutes & à tous,
bonjour @Bas699

En nommant préalablement "tb_Envoi" ton tableau structuré de la feuille "Données PW" et en en supprimant toutes les lignes vides (inutiles dans un tableau structuré qui s'étend automatiquement lorsque l'on ajoute des données en fin de tableau).
En nommant également les cellules contenant l'objet (Objet) et et les copies carbones (CC) (j'ai anonymisé l'adresse) dans ta feuille Mail
Je te propose ce code

Sub Envoi_mail_AtTheOne()
     Dim OutApp As Object     'Déclaration de l'application objet Outlook
     Dim OutMail As Object    'Déclaration du mail objet Outlook
     'Colonnes du tableau d'envoi
     Const ColDoc = 1, ColAdrs = 3, ColDate = 4, ColHT = 10
     Dim i As Long, NbL As Long, Adresse$, Corpsmail$
     Dim tb, lst_Adresse
    
     Set OutApp = CreateObject("Outlook.Application")
     'lire les données valables pour tous les mails
     CC = ThisWorkbook.Worksheets("Mail").[CC]
     Objet = ThisWorkbook.Worksheets("Mail").[Objet]
     BCC = ""
     'Lecture du tableau de la feuille "Données PW"
     tb = ThisWorkbook.Worksheets("Données PW").[tb_Envoi].Value
     'Initialisation
     Adresse = tb(1, ColAdrs)
     Corpsmail = ""
     NbL = UBound(tb, 1) 'nb de lignes du tableau
    
     With OutApp
          For i = 1 To NbL
               If Adresse <> tb(i, ColAdrs) Then
                    'Si l'adresse a changé, expédition
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                         .To = Adresse
                         .CC = CC
                         .BCC = BCC
                         .Subject = Objet
                         .htmlbody = "Bonjour, " & "<p>" & Corpsmail & "<p>" & "<p>" & "Cordialement ," & "<p>" & "<p>" & "L'équipe Doc Control"
                         .display
                         Corpsmail = ""
                    End With
               End If
               'Informations pour la ligne courante
               Set OutMail = Nothing
               Adresse = tb(i, ColAdrs)
               Corpsmail = Corpsmail & "<p>" & "Vous avez un document dont la livraison est prévue pour le " & tb(i, ColDate) & "<p>" & tb(i, ColDoc) & " - " & "<a href = '" & tb(i, ColHT) & "'>Lien_PW</a>"
          Next i
          'Envoi du dernier mail
          Set OutMail = OutApp.CreateItem(0)
          With OutMail
               .To = Adresse
               .CC = CC
               .BCC = BBC
               .Subject = Objet
               .htmlbody = "Bonjour, " & "<p>" & Corpsmail & "<p>" & "<p>" & "Cordialement ," & "<p>" & "<p>" & "L'équipe Doc Control"
               .display
          End With
     End With
    
     Set OutMail = Nothing
     Set OutApp = Nothing
End Sub

Voir Pièce jointe
Bon courage

 

[Bas699]

Merci pour ton retour, je vais regarder ça !

J'avais également une question car j'ai modifié la fin de la macro en voulant supprimer les lignes pour ne pas trop modifier la macro initiale mais j'ai un message indiquant un problème sur "adresse" (Erreur d'exécution : l'élément a été déplacé ou supprimé)

Quelqu'un sait d'où ça peut venir ?

    .Display 'ligne affiche le mail en brouillon dans Outlook, pratique pour vérifier avant d'envoyer
    '.Send 'envoie directement le mail
    '.Save 'sauvegarde le mail
    j = i - 1
       Wend
[B]    MsgBox ("Passage au mail suivant")[/B]
    End With
[B]      Worksheets("Données PW").Range("A2 : A" & j).EntireRow.Delete[/B]
Loop

      
Set OutMail = Nothing 'nettoie la mémoire en nettoyant les variables
Set OutApp = Nothing 'nettoie la mémoire en nettoyant les variables
End Sub 'fin du programme

J'avais juste rajouté cette partie-là à la fin. Je pensais utiliser une message Box pour voir les messages les uns après les autres avant de les envoyer.

 

[AtTheOne]

Bonjour @Bas699
Peux-tu envoyer la totalité de la macro et une capture d'écran de la ligne surlignée en jaune lors du plantage.