Mail via OUTLOOK suivant un tableau

Bonjour à tous,

Je cherche à travers une extraction de mon ERP sous excel à envoyer les informations à plusieurs personnes par mail via OUTLOOK (Pack office 2013).

Pour cela :

Dans la feuille 1 de mon classeur je mets les données de mon ERP.

Dans le feuille 2 je mets les contacts avec leur mail.

Le but est d'envoyer par mail les lignes qui correspondent au demandeur en B2 en répétant pour chaque interlocuteur la ligne 1 en plus directement dans le corps du mail. J'ai récupéré deux bouts deux code VBA qui pourraient presque fonctionner mais je suis certain qu'il est possible de faire mieux. N'étant pas très fort voir pas du tout en VBA je sollicite votre aide.

Merci d'avance pour nos échanges sur le sujet.

Bonjour,

ci-joint code

'Ajouter référence Microsoft Outlook Object Library

'Ajouter référence Microsoft Scripting Runtime

Sub Envoie_mail()

    Dim xl As Excel.Application
    Dim Ol As Outlook.Application
    Dim eMail As MailItem
    Dim ligne_début, ligne_nom, nom, sujet, lignes_message, message As String
    Dim pièces As New Dictionary
    Dim ligne_entête, ligne, plage_destinataires, destinataire As Range
    Dim lignes As Object

    'assignation de l'application Excel
    Set xl = Application

    'définition ligne entête et plage de lignes utilisées
    With Feuil1.UsedRange                                       ' plage utilisée de la feuille 1
        Set ligne_entête = .Rows(1)                             ' ligne 1
        Set plage_lignes = .Offset(1).Resize(.Rows.Count - 1)   ' lignes 2 à la dernière utilisée
    End With

    '...........  ajout des lignes de messages avec pour clé le nom en colonne 2 et pour données les lignes associées au nom

    ' transformation données de la ligne d'entête en chaîne délimitée par "|"
    ligne_début = Join(xl.Transpose(xl.Transpose(ligne_entête.Value)), "|")

    ' stockage des lignes de la plage dans le dictionnaire "pièces"
    For Each ligne In plage_lignes.Rows
        nom = ligne.Columns(2).Value
        ' transformation données de la ligne en chaîne délimitée par "|"
        ligne_nom = Join(xl.Transpose(xl.Transpose(ligne.Value)), "|")
       ' stockage
        If Not pièces.Exists(nom) Then
            Set lignes = CreateObject("System.Collections.ArrayList")
            lignes.Add (ligne_début)
            lignes.Add (ligne_nom)
            pièces.Add Key:=nom, Item:=lignes
        Else
            Set lignes = pièces(nom)
            lignes.Add (ligne_nom)
            Set pièces(nom) = lignes
        End If
    Next

    '...........  Envoi des mails

    'Assignation de l'application Outlook :
    Set Ol = CreateObject("outlook.application")

    'assignation de la plage des destinataires du mail
    With Feuil2
       Set plage_destinataires = .[A1:B4]
    End With

    ' Envoi mail pour chaque destinataire
    For Each destinataire In plage_destinataires.Rows

        '....... Assignation objet email
        Set eMail = Ol.CreateItem(olMailItem)

        ' ...... définition sujet, message et adresse mail
        ' sujet
        sujet = "Demande de chiffrage"
        ' message
        message = "<I>Bonjour</I><br><br>blablabla<br><br>"
        nom = destinataire.Columns(1).Value
        Set lignes = pièces(nom)      'récupération lignes de message associées au nom
        lignes_message = Join(lignes.ToArray, "<br>")
        message = message & lignes_message & "<br>Cordialement"
        ' adresse
        adresse = destinataire.Columns(2).Value

        '....... remplissage sujet, objet, et adresse
        eMail.Subject = sujet
        eMail.HTMLBody = message
        eMail.To = adresse

        '....... envoie le message
        eMail.Send

    Next

End Sub

Bonsoir thev,

Merci pour la réponse, je viens de tester le code VBA est il à l'air de bien marcher par rapport à ma demande.

Je vais la tester plus en détail se weekend, par contre en faisant un test rapide si j'augmente la plage j'ai une erreur d’exécution.

la plage actuelle est plage_destinataires = .[A1:B4] mais si je la passe à plage_destinataires = .[A1:B200] car nous sommes susceptible de rajouter des contacts la j'ai une erreur d'exécution.

Est-il possible de la prolonger sur 200 lignes ?

Merci

Le plus simple est alors de redéfinir la plage des destinataires en fonction des lignes utilisées pour les colonnes A et B. Comme ceci :

'assignation de la plage des destinataires du mail

    With Feuil2.UsedRange
       Set plage_destinataires = .Columns("A:B")
    End With

Ce qui vous permettra de rajouter autant de destinataires que souhaité.

Bonsoir,

Cette solution marche mais je viens de trouver d'ou vient l'erreur d'exécution.

Si dans la feuille 2 je rajoute un contact qui ne se trouve pas dans la feuille 1 à relancer du coup il me dit erreur d’exécution.

Sachant que d'un mois à l'autre les lignes changent certaine personne ne seront plus dans la feuille 1 donc plus rien à relancer pour eux.

Est-il possible dans se cas de les ignorer?

Merci d'avance.

OUI. en activant la routine de gestion d'erreurs comme suit

   
    ' Envoi mail pour chaque destinataire
     For Each destinataire In plage_destinataires.Rows
        On Error Resume Next    'activation routine d'erreur
        '....... Assignation objet email
         Set eMail = Ol.CreateItem(olMailItem)

        ' ...... définition sujet, message et adresse mail
        ' sujet
         sujet = "Demande de chiffrage"
        ' message
         message = "<I>Bonjour</I><br><br>blablabla<br><br>"
        nom = destinataire.Columns(1).Value
        Set lignes = pièces(nom)     'récupération lignes de message associées au nom
         lignes_message = Join(lignes.ToArray, "<br>")
        message = message & lignes_message & "<br><br>Cordialement"
        ' adresse
         adresse = destinataire.Columns(2).Value

        '....... remplissage sujet, objet, et adresse
         eMail.Subject = sujet
        eMail.HTMLBody = message
        eMail.To = adresse

        '....... envoie le message
         eMail.Send
        If Err.Number <> 0 Then
            MsgBox "erreur : " & Err.Description & "  nom = " & nom
            Err.Clear
        End If

    Next

Bonjour Thev, Bonjour le forum,

Merci de ton aide. J'ai modifié la macro pour mon besoin mais le pb est qu'elle envoie plus de 200 mails. Normalement elle ne devrait en envoyer que 33 car j'ai seulement 33 personnes à relancer dans la feuille 1.

Je te joint mon fichier si tu trouve l’erreur je suis preneur.

Merci d'avance de ton aide.

PS : Je ne serais ^pas le seul à utiliser le fichier. Est-il possible qu'il fonctionne sans avoir à ajouter

'Ajouter référence Microsoft Outlook Object Library

'Ajouter référence Microsoft Scripting Runtime

Merci

Bonjour,

Pour ne récupérer que 33 mails, il suffit de tester l'existence du nom dans l'objet "Dictionnary" qui stocke les lignes de la Feuille 1.

Pour se passer de la référence Microsoft Outllook, il suffit de mettre en commentaire la définition des objets Outlook.

En revanche pour se passer de la référence Microsoft Scripting Runtime, il faudrait logiquement remplacer l'instruction

Dim pièces As New Dictionary

par

Dim pièces As object
Set pièces = CreateObject("Scripting.Dictionary") 

mais ça ne fonctionne pas dans ma version d'Excel. A voir si ça fonctionne sur la tienne.

ci-dessous code mis à jour

Sub Envoi_mail()

    Dim xl As Excel.Application
    'Dim Ol As Outlook.Application
     'Dim eMail As MailItem
     Dim ligne_début, ligne_nom, nom, sujet, lignes_message, message As String
    Dim pièces As New Dictionary
    Dim ligne_entête, ligne, plage_destinataires, destinataire As Range
    Dim lignes As Object

    'assignation de l'application Excel
     Set xl = Application

    'définition ligne entête et plage de lignes utilisées
     With Feuil1.UsedRange                                       ' plage utilisée de la feuille 1
        Set ligne_entête = .Rows(1)                             ' ligne 1
        Set plage_lignes = .Offset(1).Resize(.Rows.Count - 1)   ' lignes 2 à la dernière utilisée
     End With

    '...........  ajout des lignes de message avec pour clé le nom en colonne 2 et pour données les lignes associées au nom

    ' transformation données de la ligne d'entête en chaîne délimitée par "|"
     ligne_début = Join(xl.Transpose(xl.Transpose(ligne_entête.Value)), "|")

    ' stockage des lignes de la plage dans le dictionnaire "pièces"
     For Each ligne In plage_lignes.Rows
        nom = ligne.Columns(2).Value
        ' transformation données de la ligne en chaîne délimitée par "|"
         ligne_nom = Join(xl.Transpose(xl.Transpose(ligne.Value)), "|")
        ' stockage
         If Not pièces.Exists(nom) Then
            Set lignes = CreateObject("System.Collections.ArrayList")
            lignes.Add (ligne_début)
            lignes.Add (ligne_nom)
            pièces.Add Key:=nom, Item:=lignes
        Else
            Set lignes = pièces(nom)
            lignes.Add (ligne_nom)
            Set pièces(nom) = lignes
        End If
    Next

    '...........  Envoi des mails

    'Assignation de l'application Outlook :
     Set Ol = CreateObject("outlook.application")

    'assignation de la plage des destinataires du mail
     With Feuil2.UsedRange
       Set plage_destinataires = .Columns("A:B")
    End With

    ' Envoi mail pour chaque destinataire
     For Each destinataire In plage_destinataires.Rows
        On Error Resume Next    'activation routine d'erreur
        '....... Assignation objet email
         Set eMail = Ol.CreateItem(olMailItem)

        ' ...... définition sujet, message et adresse mail
        ' sujet
         sujet = "Demande de chiffrage"
        ' message
         message = "<I>Bonjour</I><br><br>blablabla<br><br>"
        nom = destinataire.Columns(1).Value
        If pièces.Exists(nom) Then   'si le nom existe dans la feuille 1

            Set lignes = pièces(nom)     'récupération lignes de message associées au nom
             lignes_message = Join(lignes.ToArray, "<br>")
            message = message & lignes_message & "<br><br>Cordialement"
            ' adresse
             adresse = destinataire.Columns(2).Value

            '....... remplissage sujet, objet, et adresse
             eMail.Subject = sujet
            eMail.HTMLBody = message
            eMail.To = adresse

            '....... envoie le message
             eMail.Send

        End If

        If Err.Number <> 0 Then
            MsgBox "erreur : " & Err.Description & "  nom = " & nom
            Err.Clear
        End If

    Next

End Sub

Merci bcp Thev pour ton aide.

Le sujet est clos, la macro marche et répond à parfaitement à ma demande.

Rechercher des sujets similaires à "mail via outlook suivant tableau"