Filtre tableau selon valeur puis envoi d'un mail

Bonjour à tous,

Je suis nouveau sur ce forum et recherche de l'aide des experts pour m'aider à atteindre ce que je souhaite faire avec excel.

Venons en au fait !

Voici un excel Test pour vous présenter mon cas :

J'ai un tableau qui en feuille 1 reprend un tableau classique de donnée avec un responsable d'action en colonne B une société en colonne C un contact en colonne D et un numéro de téléphone en colonne E.
Dans la feuille 2 j'ai mis une aide pour les macros surtout pour la partie mail. avec les initiales des contacts et les adresses mails associées.

Ce que je souhaite :

Etape 1 :

Faire une boucle de filtre de la colonne B de la feuille (responsable d'action) avec tous les contacts en feuille 2.

Etape 2 :
Puis préparer un mail avec :
- L'adresse mail du contact en colonne C de la feuille 2

- Objet : "Objet test"

- Corps du texte :
" Voici vos contacts " + copier coller des valeurs des colonnes C à E suite au filtre de la feuille 1 (voir Etape 1)

Etape 3 :

Envoyer le mail si non vide.

Etape 4 :

Boucle des étapes 1 à 3 sur tout les responsable d'action de la colonne B de la feuille 2.

Etape 5 :

Messagebox avec "C'est fini ! "

Par avance un grand merci à tous ceux qui peuvent m'aider ! J'aimerais progresser et débute dans les macros.

bonsoir,

Sub Send_Mails()
     Dim sErreur

     arr_mail = Sheets("feuille 2").Range("B3:C14").Value     'emailaddresses
     arr_T3 = Sheets("feuille 1").ListObjects("Tableau3").DataBodyRange.Value     'votre tableau

     Set OutApp = CreateObject("Outlook.Application")     'outlook starten
     For i = 1 To UBound(arr_T3)
          If arr_T3(i, 1) <> "" Then
               DoEvents
               r = Application.Match(arr_T3(i, 1), Application.Index(arr_mail, 0, 1), 0)
               If IsNumeric(r) Then
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                         .To = arr_mail(r, 2)     'emailadres ontvanger
                         .Subject = "Objet test"
                         .Body = "Voici vos contacts " & vbLf & arr_T3(i, 2) & vbLf & arr_T3(i, 3) & vbLf & arr_T3(i, 4)
     '.save   'sauvegarder
                         .Display
     '.Send
                    End With
               Else
                    sErreur = sErreur & IIf(Len(sErreur) = 0, "", vbLf) & arr_T3(i, 1) & "n'a pas un emailaddress"     'resumer toutes les problemes
               End If
          End If
          Set OutMail = Nothing

     Next
     Set OutApp = Nothing
     If Len(sErreur) > 0 Then MsgBox sErreur, vbInformation, UCase("Problemes")
End Sub

Merci beaucoup pour la proposition !

J'ai essayé d'analysé le code ça me permettra de progresser aussi.

En faisant tourner le code j'observe 2 choses :

- Le code envoie 1 mail par ligne avec son nom de responsable. (est-il possible de trier sur les noms des responsable (feuille1/colonneB et s'il y a plusieur fois 1 nom envoyer tous les contacts sur un seul mail ? Exemple avec "wr" qui a 2 contacts) C'est de ma faute j'ai mal exprimé mon besoin.

- Je n'ai pas de message box avec "C'est fini ! " à la fin. (ça me permettra d'avoir le code pour plus tard )

Un très très grand merci ! A moi de décortiquer cette macro maintenant !

bonjour,

le problème ici, on sait ajouter une colonne à un array(tableau) mais ne pas une ligne. C'est pourquoi les données sont transposées dans le dictionary

Sub rassembler()

     '******************************************************
     'explication en anglais, désolé
     'https://excelmacromastery.com/vba-dictionary/
     '******************************************************

     Dim it(), MesClefs

     Set dict = CreateObject("scripting.dictionary")     'dictionary comme cahier de brouillon
     dict.CompareMode = vbTextCompare

     arr_mail = Sheets("feuille 2").Range("B3:C14").Value     'emailaddresses
     arr_t3 = Sheets("feuille 1").ListObjects("Tableau3").DataBodyRange.Value     'votre tableau
     For i = 1 To UBound(arr_t3)     'boucle tes données
          If arr_t3(i, 1) <> "" Then
               If Not dict.exists(arr_t3(i, 1)) Then     'nouveau "qui"
                    dict.Add arr_t3(i, 1), Application.Transpose(Application.Index(arr_t3, i, 0))     'ajoute un noveau key avec toute la ligne du tableau3 "transposé"
               Else     'exist déjà
                    it = dict(arr_t3(i, 1))     'les données de ce 'qui" jusqu'à maintenant
                    ReDim Preserve it(1 To UBound(it), 1 To UBound(it, 2) + 1)     'ajoute une colonne supplementaire sans oublier le contenu actuelle
                    For j = 1 To UBound(it)     'dans un boucle
                         it(j, UBound(it, 2)) = arr_t3(i, j)     'adjouter les données nouveau
                    Next
                    dict(arr_t3(i, 1)) = it  'sauvegarder les nouvelles données dans le dictionary
               End If
          End If
     Next

     Set OutApp = CreateObject("Outlook.Application")     'outlook starten

     MesClefs = dict.keys     'liste de tous les unique "Qui"
     For i = 0 To UBound(MesClefs)     'boucle ces unique "Qui"
          it = dict(MesClefs(i))     'les données de ce 'qui" jusqu'à maintenant
          DoEvents
          r = Application.Match(MesClefs(i), Application.Index(arr_mail, 0, 1), 0)     'recherche son emailaddress
          If IsNumeric(r) Then
               Set OutMail = OutApp.CreateItem(0)
               With OutMail
                    .To = arr_mail(r, 2)     'emailadres ontvanger
                    .Subject = "Objet test"
                    .body = "Voici vos contacts "
                    For j = 1 To UBound(it, 2)
                         .body = .body & vbLf & it(1, j) & " - " & it(2, j) & it(3, j) & " - " & it(4, j) 'une ligne par contact
                    Next

     '.save   'sauvegarder
                    .Display
     '.Send
               End With

          End If
          Set OutMail = Nothing

     Next
     Set OutApp = Nothing

End Sub

Merci beaucoup !!!

Tu es vraiment un chef ! c'est exactement ça qu'il me faut ! ça marche très bien dans ton dernier tableau.
J'ai essayé de transposer la formule dans mon véritable tableau et j'ai eu un

« Erreur au moment de l’exécution 5 : appel de procédure non valide ou argument »

Sur la ligne de code :

 dict.Add arr_t3(i, 1), Application.Transpose(Application.Index(arr_t3, i, 0))     'ajoute un noveau key avec toute la ligne du tableau3 "transposé"

J'ai regarder ce que ça veut dire j'ai vu que c'est la mise en forme de la première colonne ? tu peux m'aiguiller car j'ai beau essayer de tout mettre en forme ça change rien du tout.

J'ai même essayer de copier coller les données dans le dernier tableau que tu as mis en pièce jointe et même erreur.

Tu as une idée de ce que je dois faire attention dans la première colonne pour l'indexation ?

re,

si vous inspectez toute la ligne i du tableau, (x colonnes), y-a-t-il une cellulle avec un valeur "erreur" ou différent ? (vide, numeric ou text sont okay)

Combien de colonnes y-a-t-il ?

RE !

J'ai inspecter tout le tableau : il y avait des erreurs que j'ai corrigée.
J'ai ensuite relancer la macro et ça ne marchait toujours pas.

Le tableau fait : 26 colonnes.

Avec cette fonction on est limité dans le nombre de colonne ?

oui, la limite est +-16.000 (2^14), donc 26 n'est pas le problème.

"appel de procédure non valide ou argument", ça veut dire qu'il se passe quelque chose indifini.

Utilisez-vous "Option Explicit" comme 1iere ligne du module ?

J'utilise exactement le même module que celui qu'on avait fait ensemble sauf que j'ai remplacé les noms des feuilles :

Feuille 1 ==> Prospection

Feuille 2 ==> relance

Sub Send_Mails()
     Dim sErreur

     arr_mail = Sheets("relance").Range("B3:C14").Value     'emailaddresses
     arr_t3 = Sheets("PROSPECTION").ListObjects("Tableau3").DataBodyRange.Value     'votre tableau

     Set OutApp = CreateObject("Outlook.Application")     'outlook starten
     For i = 1 To UBound(arr_t3)
          If arr_t3(i, 1) <> "" Then
               DoEvents
               r = Application.Match(arr_t3(i, 1), Application.Index(arr_mail, 0, 1), 0)
               If IsNumeric(r) Then
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                         .To = arr_mail(r, 2)     'emailadres ontvanger
                         .Subject = "Objet test"
                         .body = "Voici vos contacts " & vbLf & arr_t3(i, 2) & vbLf & arr_t3(i, 3) & vbLf & arr_t3(i, 4)
     '.save   'sauvegarder
                         .Display
     '.Send
                    End With
               Else
                    sErreur = sErreur & IIf(Len(sErreur) = 0, "", vbLf) & arr_t3(i, 1) & "n'a pas un emailaddress"     'resumer toutes les problemes
               End If
          End If
          Set OutMail = Nothing

     Next
     Set OutApp = Nothing
     If Len(sErreur) > 0 Then MsgBox sErreur, vbInformation, UCase("Problemes")
End Sub

Sub rassembler()

     '******************************************************
     'explication en anglais, désolé
     '******************************************************

     Dim it(), MesClefs

     Set dict = CreateObject("scripting.dictionary")     'dictionary comme cahier de brouillon
     dict.CompareMode = vbTextCompare

     arr_mail = Sheets("relance").Range("B3:C14").Value     'emailaddresses
     arr_t3 = Sheets("PROSPECTION").ListObjects("Tableau3").DataBodyRange.Value     'votre tableau
     For i = 1 To UBound(arr_t3)     'boucle tes données
          If arr_t3(i, 1) <> "" Then
               If Not dict.exists(arr_t3(i, 1)) Then     'nouveau "qui"
                    dict.Add arr_t3(i, 1), Application.Transpose(Application.Index(arr_t3, i, 0))     'ajoute un noveau key avec toute la ligne du tableau3 "transposé"
               Else     'exist déjà
                    it = dict(arr_t3(i, 1))     'les données de ce 'qui" jusqu'à maintenant
                    ReDim Preserve it(1 To UBound(it), 1 To UBound(it, 2) + 1)     'ajoute une colonne supplementaire sans oublier le contenu actuelle
                    For j = 1 To UBound(it)     'dans un boucle
                         it(j, UBound(it, 2)) = arr_t3(i, j)     'adjouter les données nouveau
                    Next
                    dict(arr_t3(i, 1)) = it  'sauvegarder les nouvelles données dans le dictionary
               End If
          End If
     Next

     Set OutApp = CreateObject("Outlook.Application")     'outlook starten

     MesClefs = dict.keys     'liste de tous les unique "Qui"
     For i = 0 To UBound(MesClefs)     'boucle ces unique "Qui"
          it = dict(MesClefs(i))     'les données de ce 'qui" jusqu'à maintenant
          DoEvents
          r = Application.Match(MesClefs(i), Application.Index(arr_mail, 0, 1), 0)     'recherche son emailaddress
          If IsNumeric(r) Then
               Set OutMail = OutApp.CreateItem(0)
               With OutMail
                    .To = arr_mail(r, 2)     'emailadres ontvanger
                    .Subject = "Objet test"
                    .body = "Voici vos contacts "
                    For j = 1 To UBound(it, 2)
                         .body = .body & vbLf & it(1, j) & " - " & it(2, j) & it(3, j) & " - " & it(4, j) 'une ligne par contact
                    Next

     '.save   'sauvegarder
                    .Display
     '.Send
               End With

          End If
          Set OutMail = Nothing

     Next
     Set OutApp = Nothing

End Sub

Pour faire plus simple j'ai copier coller dans le tableau qu'on avait fait ensemble les données pour voir si ça vennait bien des données et la réponse est : Oui ça ne marche plus non plus.

Il y a quelque chose dans les données qui bloque la macro.

Edit je viens de trouver une formule circulaire que j'ai supprimé. ==> la macro bloque toujours.

Edit !!

J'ai supprimé une à une toute les colonnes pour trouver ce qui ne marchait pas ! C'était une colonne de soustraction de date... sous format date.
J'ai réglé le problème c'est maintenant tout bonnement parfait.

Un très grand merci pour le temps passer avec moi pour m'aider sur mon idée. J'ai bien appris avec toi !

Merciiii

il y a un probleme avec des données sous forme de "dates" (dd-mm-yy, etc) et "currency" (avec €, $, ...).
Dès qu'on a une colonne parreil et on utilise cette colonne dans le macro, c'est mieux d'utiliser "Value2".
de cette facon, l'array lis les données comme des valeurs type "double"

arr_t3 = Sheets("PROSPECTION").ListObjects("Tableau3").DataBodyRange.Value2 'votre tableau

Super merci beaucoup je clos la question c'est tout bon pour moi un grand merci !