Envoi email automatique
Bonjour ,
J'ai un fichier excel qui contient plusieurs onglet ,, chaque onglet est une agence a qui je veux envoyer un e mail
est ce que c possible d'automatisé tout ça .
Bonjour,
oui c'est possible mais il manque beaucoup de précisions (as-tu outlook ? contenu du mail? adresse mail ? ect ...)
Fait attention à bien anonymiser ton fichier avant de le poster sur un forum !
Cordialement
Bonjour,
oui c'est possible mais il manque beaucoup de précisions (as-tu outlook ? contenu du mail? adresse mail ? ect ...)
Fait attention à bien anonymiser ton fichier avant de le poster sur un forum !
Cordialement
oui j'ai outlook pour le contenu c'est les onglet pour chaque onglet c'est une adresse mail . tu veux comme quoi comme détails
Bonsoir abdernino,
voici le code et un fichier exemple, j'ai mis dans chaque onglet l'adresse email de l'agence dans la cellule "B1":
Sub EnvoiOnglet()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim Destinataire As String
Dim Sujet As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each ws In Worksheets
If ws.Name <> "Feuil1" And ws.Name <> "Modèle" Then
Set Sourcewb = ActiveWorkbook
ws.Copy
Set Destwb = ActiveWorkbook
FileExtStr = ".xlsx": FileFormatNum = 51
TempFilePath = ThisWorkbook.Path
TempFileName = ActiveSheet.Name
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
Destinataire = Sheets(1).Range("B1")
Sujet = Sheets(1).Range("F2")
With OutMail
.to = Destinataire
.CC = ""
.BCC = ""
.Subject = Sujet
.Body = "Veuillez trouver...."
.Attachments.Add Destwb.FullName
.display
'.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
End If
Next ws
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Cordialement
Bonsoir,
Je m'excuse, j'ai téléchargé le mauvais fichier avec une erreur dans le code
Kill TempFilePath & TempFileName & FileExtStr
avec
Kill TempFileName & FileExtStr
Bonsoir,
Je m'excuse, j'ai téléchargé le mauvais fichier avec une erreur dans le code
. Remplacer la ligne: Kill TempFilePath & TempFileName & FileExtStr
avec
Kill TempFileName & FileExtStr
Bonjour et merci pour ton aide
1- si je doit insérer un texte avec le tableau comment faire .
2- la macro est ce que je dois l’insérer dans un bouton .
Salut abdernino,
Je joins une nouvelle version du fichier avec un bouton pour lancer automatiquement la macro.
En ce qui concerne le texte de l'e-mail, tu peux personnaliser cette partie du code en changeant les mots entre guillemets (en rouge), & vbNewLine & indique un retour chariot :
.Body = "Bonjour," & vbNewLine & "Veuillez trouver....," & vbNewLine & "Cordialement."
Salut abdernino,
Je joins une nouvelle version du fichier avec un bouton pour lancer automatiquement la macro.
En ce qui concerne le texte de l'e-mail, tu peux personnaliser cette partie du code en changeant les mots entre guillemets (en rouge), & vbNewLine & indique un retour chariot :
.Body = "Bonjour," & vbNewLine & "Veuillez trouver....," & vbNewLine & "Cordialement."
Merci beaucoup
est ce qu'il envoie automatiquement de ma boite qui est déjà installé.et pour les adresse est ce que peut la la caché
Salut abdernino,
je joins une nouvelle version du fichier que j'ai créé, j'ai ajouté un onglet pour les adresses e-mail et donc plus besoin de les écrire sur chaque feuille, Il suffit de les mettre à jour une fois pour toujour.
Voici le code:
Sub EnvoiOnglet3()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim Destinataire As String
Dim Sujet As String
Dim OutApp As Object
Dim OutMail As Object
Dim Tableau As Variant
Dim i As Integer, k As Integer, LastRow As Integer
Dim aKey As String
Dim aValue As String
Dim Dict As Object
Dim wsMail As Worksheet
Dim Adresse As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wsMail = ThisWorkbook.Sheets("Mail")
LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row
Tableau = wsMail.Range("A2:B" & LastRow)
Set Dict = CreateObject("scripting.dictionary")
For i = 1 To UBound(Tableau)
aKey = Tableau(i, 1)
aValue = Tableau(i, 2)
Dict.Add aKey, aValue
Next i
For Each ws In Worksheets
If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then
Set Sourcewb = ActiveWorkbook
ws.Copy
Set Destwb = ActiveWorkbook
FileExtStr = ".xlsx": FileFormatNum = 51
TempFilePath = ThisWorkbook.Path
TempFileName = ActiveSheet.Name
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
Adresse = Sheets(1).Range("C6").Value
Destinataire = Dict.Item(Adresse)
Sujet = Sheets(1).Range("F2")
With OutMail
.To = Destinataire
.CC = ""
.BCC = ""
.Subject = Sujet
.Body = "Bonjour," & vbNewLine & "Veuillez trouver....," & vbNewLine & "Cordialement."
.Attachments.Add Destwb.FullName
.display
'.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFileName & FileExtStr
End If
Next ws
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Pour l'envoi automatique sans afficher le message (une fois la phase de test terminée) on peut commenter la ligne de code
'.Display
et décommenter
.Send
A' bientôt
Bonjour , est ce que possible de modifié le texte en dehors de la macro
Bonjour,
tu doix expliquer plus précisément ce que tu veux faire. Le texte est le même pour chaque message? On peut écrire ce texte dans un cellule (par exemple, comme on fait dans mon code pour le sujet de l'email, toujours dans la même position - Sheets(1).Range("F2")).
Je voudrais écrire le texte dans une feuille , pas dans la macro pour pouvoir mettre un paragraphe en rouge par exemple
Bonsoir,
pour la mise en forme du texte du message, je pense qu'il faut tout de même utiliser les balises HTML dans le code de la macro, voici une nouvelle proposition:
Sub EnvoiOngletHTML()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim Destinataire As String
Dim Sujet As String
Dim OutApp As Object
Dim OutMail As Object
Dim Tableau As Variant
Dim i As Integer, k As Integer, LastRow As Integer
Dim aKey As String
Dim aValue As String
Dim Dict As Object
Dim wsMail As Worksheet
Dim Adresse As String
Dim strBody As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wsMail = ThisWorkbook.Sheets("Mail")
LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row
Tableau = wsMail.Range("A2:B" & LastRow)
Set Dict = CreateObject("scripting.dictionary")
For i = 1 To UBound(Tableau)
aKey = Tableau(i, 1)
aValue = Tableau(i, 2)
Dict.Add aKey, aValue
Next i
For Each ws In Worksheets
If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then
Set Sourcewb = ActiveWorkbook
ws.Copy
Set Destwb = ActiveWorkbook
FileExtStr = ".xlsx": FileFormatNum = 51
TempFilePath = ThisWorkbook.Path
TempFileName = ActiveSheet.Name
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
strBody = "Bonjour, <p>" & _
"Veuillez trouver...." & "<br>" & _
"<font color=red> Merci de bien vouloir...., " & "</font color=red>" & "<br>" & "Cordialement.</a></font>"
Adresse = Sheets(1).Range("C6").Value
Destinataire = Dict.Item(Adresse)
Sujet = Sheets(1).Range("F2")
With OutMail
.To = Destinataire
.CC = ""
.BCC = ""
.Subject = Sujet
.HTMLBody = strBody
.Attachments.Add Destwb.FullName
.display
'.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFileName & FileExtStr
End If
Next ws
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Bonjour,
1- je voudrais rédiger le message sans accéder a la macro, et est ce que c'est possible de rajouter au mail agence qui mettre en copie .
Merci
Bonsoir,
pour la mise en forme du texte du message, je pense qu'il faut tout de même utiliser les balises HTML dans le code de la macro, voici une nouvelle proposition:
Sub EnvoiOngletHTML() Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim Destwb As Workbook Dim ws As Worksheet Dim TempFilePath As String Dim TempFileName As String Dim Destinataire As String Dim Sujet As String Dim OutApp As Object Dim OutMail As Object Dim Tableau As Variant Dim i As Integer, k As Integer, LastRow As Integer Dim aKey As String Dim aValue As String Dim Dict As Object Dim wsMail As Worksheet Dim Adresse As String Dim strBody As String With Application .ScreenUpdating = False .EnableEvents = False End With Set wsMail = ThisWorkbook.Sheets("Mail") LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row Tableau = wsMail.Range("A2:B" & LastRow) Set Dict = CreateObject("scripting.dictionary") For i = 1 To UBound(Tableau) aKey = Tableau(i, 1) aValue = Tableau(i, 2) Dict.Add aKey, aValue Next i For Each ws In Worksheets If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then Set Sourcewb = ActiveWorkbook ws.Copy Set Destwb = ActiveWorkbook FileExtStr = ".xlsx": FileFormatNum = 51 TempFilePath = ThisWorkbook.Path TempFileName = ActiveSheet.Name Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With Destwb .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum On Error Resume Next strBody = "Bonjour, <p>" & _ "Veuillez trouver...." & "<br>" & _ "<font color=red> Merci de bien vouloir...., " & "</font color=red>" & "<br>" & "Cordialement.</a></font>" Adresse = Sheets(1).Range("C6").Value Destinataire = Dict.Item(Adresse) Sujet = Sheets(1).Range("F2") With OutMail .To = Destinataire .CC = "" .BCC = "" .Subject = Sujet .HTMLBody = strBody .Attachments.Add Destwb.FullName .display '.Send End With On Error GoTo 0 .Close savechanges:=False End With Kill TempFileName & FileExtStr End If Next ws Set OutMail = Nothing Set OutApp = Nothing With Application .ScreenUpdating = True .EnableEvents = True End With End Sub
Je voudrais pour chaque adress rajouter qui mettre en copie.
Pour le message le rédiger en dehors de la macro
Bonsoir abdernino,
voici la dernière version du fichier et le code ci-dessous. J'ai mis le message à adapter divisé en quatre parties sur la Feuille Mail et j'ai ajouté une colonne avec les adresses auxquelles envoyer la copie:
Sub EnvoiOngletHTML2()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim ws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim Destinataire As String
Dim Sujet As String
Dim OutApp As Object
Dim OutMail As Object
Dim Tableau As Variant
Dim i As Integer, k As Integer, LastRow As Integer
Dim aKey As String
Dim aValue As String
Dim Dict As Object
Dim wsMail As Worksheet
Dim Adresse As String
Dim strBody As String
Dim DestCopie As String
Dim Intro As String, TexteInit As String, TexteRouge As String, Salutation As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wsMail = ThisWorkbook.Sheets("Mail")
LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row
Intro = wsMail.Range("H2")
TexteInit = wsMail.Range("H3")
TexteRouge = wsMail.Range("H4")
Salutation = wsMail.Range("H5")
Tableau = wsMail.Range("A2:B" & LastRow)
Set Dict = CreateObject("scripting.dictionary")
For i = 1 To UBound(Tableau)
aKey = Tableau(i, 1)
aValue = Tableau(i, 2)
Dict.Add aKey, aValue
Next i
For Each ws In Worksheets
If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then
Set Sourcewb = ActiveWorkbook
ws.Copy
Set Destwb = ActiveWorkbook
FileExtStr = ".xlsx": FileFormatNum = 51
TempFilePath = ThisWorkbook.Path
TempFileName = ActiveSheet.Name
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
strBody = Intro & "<p>" & _
TexteInit & "<br>" & _
"<font color=red>" & TexteRouge & "</font color=red>" & "<br>" & Salutation
Adresse = Sheets(1).Range("C6").Value
Destinataire = Dict.Item(Adresse)
DestCopie = Application.WorksheetFunction.VLookup(Destinataire, wsMail.Range("B2:C" & LastRow), 2, False)
Sujet = Sheets(1).Range("F2")
With OutMail
.To = Destinataire
.CC = DestCopie
.BCC = ""
.Subject = Sujet
.HTMLBody = strBody
.Attachments.Add Destwb.FullName
.display
'.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFileName & FileExtStr
End If
Next ws
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Bonsoir ,
Merci beaucoup c'est parfait .
Adresse = Sheets(1).Range("C6").Value
Destinataire = Dict.Item(Adresse)
DestCopie = Application.WorksheetFunction.VLookup(Destinataire, wsMail.Range("B2:D" & LastRow), 2, j'ai essayer de rajouter d'autre personne a mettre en copie dans la colonne D mais ca marche pas
Merci
Bonsoir Abdernino et merci pour ton retour,
on peut insérer plusieurs adresses dans la même cellule (colonne C), séparées par un point-virgule, par exemple mail1@mail.com; mail2@mail.com
Merci beaucoup pour ton aide.
une dernière petite question la dispatche ce fait que s'il y a des nombres ?
Bonsoir ,
Non maintenant çà marche très bien même si il y pas de nombre
Merci beaucoup