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.
- Messages
- 4'064
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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
- Messages
- 4'064
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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.
- Messages
- 4'064
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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
- Messages
- 4'064
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
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.