Envoi mail à plusieurs personnes selon conditions

Bonjour à tous,

Je reviens vers vous car vous m'avez particulièrement bien aidé les fois précédentes. Je commence à progresser sur vba, seulement, il me reste 2 point bloquants pour parfaire mon code.

Je souhaite envoyer un mail à plusieurs personnes en fonction des valeurs de cellules, qui correspondent aux services concernés par la demande. Actuellement, ma macro prépare un mail par destinataire, cependant je souhaite :

1. Envoyer un seul mail avec l'ensemble des destinataires.
2. Supprimer les destinataires en double.

Je vous remercie par avance pour votre aide. Le code que j'utilise actuellement est le suivant :

Sub Mail()

Dim LeMail As Object
Dim Ligne As Integer
Dim cell As Range

Set LeMail = CreateObject("outlook.application") 'création d'un objet outlook

    For Ligne = 4 To Worksheets("Listes").Range("J5").Value + 4  'Pour chaque ligne correspond aux numéros des lignes du tableau AdressesMail

    If Worksheets("Listes").Range("F" & Ligne) = Worksheets("Formulaire DSD").Range("H13") Or Worksheets("Listes").Range("F" & Ligne) = Worksheets("Formulaire DSD").Range("H18") Then
         With LeMail.CreateItem(0)
                .Subject = "Nouveau mail 'Sujet du mail"
                .To = Worksheets("Listes").Range("G" & Ligne) 'Destinataire
                .Body = "Bonjour," & vbCr & vbLf & "Un nouveau mail."
                .Display 'permet d'afficher le mail avant d'envoyer le mail
            '  .Send 'envoi du mail
                End With

    End If

Next Ligne

End Sub

Bonjour,

Auriez-vous une solution à mon problème ?

Bonjour Tik et Tok,

Il ne faut pas hésiter à faire des recherches sur internet. Tu vas trouver aisément comment avoir plusieurs destinataires pour un mail.

Pour éviter d'avoir des doublons, utilise un dictionnaire :

Dim MonDico As New Scripting.Dictionary
Dim Cel as Range

Set MonDico = CreateObject("Scripting.Dictionary")

For Each Cel In Worksheets("Listes").Range("G" & Ligne)
    MonDico.Add Key:=Cel
Next Cel

Et tu récupères ta liste de destinataires sans doublon avec : MonDico.Keys

Bonjour le fil,

@Tik et Tok, je n'ai pas trop bien compris le risque de doublon au niveau des mails

@Baboutz, moi je préfère utiliser une collection, pas besoin d'ajouter la référence Microsoft

Voici le code

Sub Mail()
  Dim ObjOut As Object
  Dim ObjMail As Object
  Dim FirstRow As Long, LastRow As Long, Lig As Long
  Dim LstObj As ListObject
  Dim MaCol As New Collection
  Dim Service As String
  Dim Dest As String  ' Liste du/des destinataire
  ' Récupérer el nom du service
  Service = ThisWorkbook.Sheets("Formulaire DSD").Range("H18")
  ' Définir le tableau des emails
  Set LstObj = ThisWorkbook.Sheets("Listes").ListObjects("AdressesMail")
  ' Première ligne et dernière ligne du tableau structuré
  FirstRow = LstObj.HeaderRowRange.Row + 1
  LastRow = LstObj.DataBodyRange.Rows.Count
  Dest = ""
  ' ¨Pour chaque ligne
  For Lig = FirstRow To LastRow
    ' Vérifier s'il s'agit du service
    If LstObj.DataBodyRange.Cells(Lig, 1) = Service Then
      ' N'ajouter que si l'email est différent
      On Error Resume Next
      MaCol.Add Lig, LstObj.DataBodyRange.Cells(Lig, 2)
      If Err.Number = 0 Then
        Dest = Dest & LstObj.DataBodyRange.Cells(Lig, 2) & "; "
      End If
      On Error GoTo 0
    End If
  Next Lig
  ' Supprimer le dernier pointvirgule
  Dest = Left(Dest, Len(Dest) - 2)
  ' Créer une instance outlook
  Set ObjOut = CreateObject("outlook.application")
  ' créer une instance de mail
  Set ObjMail = ObjOut.CreateItem(0)
  ' Avec le nouveau mail
  With ObjMail
    .Display
    .Subject = "Nouveau mail" 'Sujet du mail
     .To = Dest
    .Body = "Bonjour," & vbCr & vbLf & "Un nouveau mail."
   End With
  ' Effacer les variables objet
  Set LeMail = Nothing: Set LstObj = Nothing
End Sub

@+

C'est vrai BrunoM45, c'est tout aussi bien !

Beau code

Bonjour Baboutz et BrunoM45,

Merci pour vos réponses, elles me sont d'une grande aide.

J'ai préalablement à la demande d'aide sur le forum fait des recherches sur internet, seulement je n'ai pas trouvé d'extrait de code correspondant réellement à mes besoins.

@BrunoM45, j'ai compris ton incompréhension par rapport aux mails en doublon, effectivement tu envoi un mail uniquement en fonction d'une case. Hors ici mon code doit tenir compte des cellules suivantes : "ThisWorkbook.Sheets("Formulaire DSD").Range("H18") et ThisWorkbook.Sheets("Formulaire DSD").Range("H13")".

J'ai modifié ton code en ajoutant une nouvelle variable et ça a l'air de fonctionner :

 Dim Service As String, Service2 As String

  ' Récupérer el nom du service
  Service = ThisWorkbook.Sheets("Formulaire DSD").Range("H13")
  Service2 = ThisWorkbook.Sheets("Formulaire DSD").Range("H18")

 If LstObj.DataBodyRange.Cells(Lig, 1) = Service Or LstObj.DataBodyRange.Cells(Lig, 1) = Service2 Then

@Baboutz, j'ai essayé d'utiliser ton code, cependant en le lançant j'ai le message d'erreur suivant : " Erreur de compilation: Type défini par utilisateur non défini". Quand je vais sur le code, c'est à la déclaration de la variable qu'il y aurait un problème

Sais-tu quel peut être la cause à l'origine de cette erreur ?

Merci à vous deux pour votre aide

Bonjour Tik et Tok

C'est ce que je disais préalablement à Baboutz,
pour que son code fonctionne il faut ajouter la référence "Microsoft Scripting Runtime"

@+

Bonjour à tous,

En remplaçant la déclaration par :

Dim MonDico As object

Le code devrait marcher même sans la référence. Mais dans ce cas, vous ne pourrez plus bénéficier de la saisie assistée.

Cdlt,