Mail via OUTLOOK suivant un tableau Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Avatar du membre
Djay37
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 1 juillet 2016
Version d'Excel : 2013 FR

Message par Djay37 » 1 juillet 2016, 09:13

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.
commande da avec macro.xlsm
Base de travail
(30.92 Kio) Téléchargé 20 fois
Avatar du membre
thev
Membre impliqué
Membre impliqué
Messages : 2'476
Appréciations reçues : 209
Inscrit le : 13 juin 2016
Version d'Excel : 2019 FR 64 bits

Message par thev » 1 juillet 2016, 13:54

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

Avatar du membre
Djay37
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 1 juillet 2016
Version d'Excel : 2013 FR

Message par Djay37 » 1 juillet 2016, 16:18

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
Avatar du membre
thev
Membre impliqué
Membre impliqué
Messages : 2'476
Appréciations reçues : 209
Inscrit le : 13 juin 2016
Version d'Excel : 2019 FR 64 bits

Message par thev » 1 juillet 2016, 16:43

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é.
Avatar du membre
Djay37
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 1 juillet 2016
Version d'Excel : 2013 FR

Message par Djay37 » 1 juillet 2016, 19:04

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.
Avatar du membre
thev
Membre impliqué
Membre impliqué
Messages : 2'476
Appréciations reçues : 209
Inscrit le : 13 juin 2016
Version d'Excel : 2019 FR 64 bits

Message par thev » 1 juillet 2016, 22:20

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
Avatar du membre
Djay37
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 1 juillet 2016
Version d'Excel : 2013 FR

Message par Djay37 » 4 juillet 2016, 11:11

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.
COMMANDE DA TEST LUNDI.xlsm
Nouveau fichier test
(33.33 Kio) Téléchargé 13 fois
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
Avatar du membre
thev
Membre impliqué
Membre impliqué
Messages : 2'476
Appréciations reçues : 209
Inscrit le : 13 juin 2016
Version d'Excel : 2019 FR 64 bits

Message par thev » 4 juillet 2016, 12:28

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
Modifié en dernier par thev le 4 juillet 2016, 21:04, modifié 2 fois.
Avatar du membre
Djay37
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 1 juillet 2016
Version d'Excel : 2013 FR

Message par Djay37 » 4 juillet 2016, 15:18

Merci bcp Thev pour ton aide.

Le sujet est clos, la macro marche et répond à parfaitement à ma demande.
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message