Recherche dans un mailling VBA sur la ligne "to"
Bonjour,
J'ai réalisé ma macro de mailling qui envoie un mail à la personne de chaque onglet. Jusque là tout fonctionne. Seulement je veux que dans le destinataire je puis faire une recherche v dans un tableau avec la bonne adresse selon le nom, mais cela ne fonctionne pas
J'ai tout essayé mais la recherche en se fait pas est ce que vous pouvez m'aider s'il vous plait ?
voici le code :
Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see:
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
'Sauvegare la nouvelle classeur; envoie l'email; efface le classeur créé
TempFilePath = Environ$("temp") & "\"
'Determine la version Excel et le type de fichier/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
'Determine la valeur en cellule B1 si correct pour le publipostage
For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value Like "?*@?*.?*" Then
'Copie la feuille active dans un nouveau classeur
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Réception PO " & Format(Now, "dd-mmm-yy")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:B14"), 2, False)
.CC = "joseph.verdier@emea.shiseido.com"
.BCC = ""
.Subject = "Relance MIGO"
.BodyFormat = olFormatHTML
.HTMLBody = "<HTML><body>Bonjour,<br /><br />" & _
"Voici le détail de vos commandes non réceptionnées et/ou non validées avec une date de réception sur le mois en cours. Pouvez-vous les faire valider et les réceptionner au plus vite SVP ?<br />" & _
"<FONT COLOR=RED><b><u>Deadline : Dernier jour ouvré du mois en cours au plus tard.</u></b></FONT><br /><br />" & _
"<b><u>Rappel 1 :</u></b> la prestation est à réceptionner que si elle a été réalisée. Si elle n'a pas encore été réalisée, il faut décaler la date de réception et ne pas réceptionner la commande.<br /><br />" & _
"<b><u>Rappel 2 :</u></b> La <b>ligne et la marque</b> doivent être <b>obligatoirement saisies</b> dans les PO.<br />" & _
"Merci de modifier vos PO et de rajouter la ligne et la marque, SVP. Pour que la marque se renseigne, il faut d'abord renseigner la ligne, faire Entrée et la marque se dérivera automatiquement<br /><br />" & _
"Je reste à votre disposition pour tous compléments d'informations.<br /><br />" & _
"Cordialement,<br /><br /><br /><br />" & _
"Hello everyone,<br /><br />" & _
"Kind reminder, there's still non validated and non receipt PO on February. See the extraction attached.<br />" & _
"Can you please make the necessary with your team to validate and receipt or postpone <FONT COLOR=RED><b>ASAP ?</b></FONT><br /><br />" & _
"<b><u>Recall n°1 :</u></b> The service is to be <FONT COLOR=RED>receipt only if it has been carried out</FONT>. If it has not been done yet, it is necessary to postpone the date of reception and not to receive the order.<br />" & _
"<FONT COLOR=RED><b><u>Deadline : ASAP</u></b></FONT><br /><br />" & _
"<b><u>Recall n°2 :</u></b> The line and the brand must be entered in POs. There's still PO's without brand and line.<br /><br />" & _
"If you have any questions don't hesitate to come back to me,<br /><br />" & _
"Regards,"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
'Efface le fichier que vous avez envoyé
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Une boite de dialogue pour confirmer que l'email a bel et bien été envoyé
MsgBox Application.UserName & "," & vbCr & "Cette Feuille: " & ActiveSheet.Name & ", a été envoyée par email.", _
vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Envoie d'email"
End Sub
Merci pour votre aide
Salut,
une question bête: ta feuille est ben nommée "Mapping" sans espace sans rien?
salut,
Oui j'ai nommé l'onglet Mapping
Peux tu poster le contenu de quelques cellules B1 et le contenu de la plage A1:B14?
Sinon un fichier facilitera énormement la tâche!
change cette ligne:
If sh.Range("B1").Value Like "?*@?*.?*" Thencomme ca
If sh.Range("B1").Value <> "" Thenet fais un tests'il te plait. En attendant je regarde le code
Super ça fonctionne !!
Est ce que tu peux m'expliquer le changement s'il te plait ?
Dernière question :
Je souhaiterais l'envoyer sous le même format avec les même valeur mais pas en tableau de croisé dynamique.
J'ai trouvé des codes mais je n'arrive pas à les insérer dans ma macro.
Est ce que tu pourrais m'aider aussi ?
Super ça fonctionne !!
Est ce que tu peux m'expliquer le changement s'il te plait ?
avec Like "?*@?*.?*" <== tu cherche une donée qui est a une forme d'adresse Mail comme "test@test.fr"
si tu veux utiliser cette syntaxe tu fais: Like "?*" <== dans ce cas là il va chercher un string quelconque commee "test"
Sinon avec If sh.Range("B1").Value <> "" Then <== si la valeur de B1 n'est pas vide.
Dernière question :
Je souhaiterais l'envoyer sous le même format avec les même valeur mais pas en tableau de croisé dynamique.
J'ai trouvé des codes mais je n'arrive pas à les insérer dans ma macro.
Est ce que tu pourrais m'aider aussi ?
mets le coe que t'as trouvé et on essaie de l'adapter ensemble
c'est celui la
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
Bjr Joki,
à teseter:
Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
'Sauvegare la nouvelle classeur; envoie l'email; efface le classeur créé
TempFilePath = Environ$("temp") & "\"
'Determine la version Excel et le type de fichier/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set OutApp = CreateObject("Outlook.Application")
'Determine la valeur en cellule B1 si correct pour le publipostage
For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value Like "?*" Then
'Copie la feuille active dans un nouveau classeur
sh.PivotTables(1).TableRange1.Copy
Set Dest = Workbooks.Add(xlWBATWorksheet)
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Name = sh.Name
.Cells(1).Select
Application.CutCopyMode = False
End With
Set wb = ActiveWorkbook
TempFileName = "Réception PO " & Format(Now, "dd-mmm-yy")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:B14"), 2, False)
.CC = "joseph.verdier@emea.shiseido.com"
.BCC = ""
.Subject = "Relance MIGO"
.BodyFormat = olFormatHTML
.HTMLBody = "<HTML><body>Bonjour,<br /><br />" & _
"Voici le détail de vos commandes non réceptionnées et/ou non validées avec une date de réception sur le mois en cours. Pouvez-vous les faire valider et les réceptionner au plus vite SVP ?<br />" & _
"<FONT COLOR=RED><b><u>Deadline : Dernier jour ouvré du mois en cours au plus tard.</u></b></FONT><br /><br />" & _
"<b><u>Rappel 1 :</u></b> la prestation est à réceptionner que si elle a été réalisée. Si elle n'a pas encore été réalisée, il faut décaler la date de réception et ne pas réceptionner la commande.<br /><br />" & _
"<b><u>Rappel 2 :</u></b> La <b>ligne et la marque</b> doivent être <b>obligatoirement saisies</b> dans les PO.<br />" & _
"Merci de modifier vos PO et de rajouter la ligne et la marque, SVP. Pour que la marque se renseigne, il faut d'abord renseigner la ligne, faire Entrée et la marque se dérivera automatiquement<br /><br />" & _
"Je reste à votre disposition pour tous compléments d'informations.<br /><br />" & _
"Cordialement,<br /><br /><br /><br />" & _
"Hello everyone,<br /><br />" & _
"Kind reminder, there's still non validated and non receipt PO on February. See the extraction attached.<br />" & _
"Can you please make the necessary with your team to validate and receipt or postpone <FONT COLOR=RED><b>ASAP ?</b></FONT><br /><br />" & _
"<b><u>Recall n°1 :</u></b> The service is to be <FONT COLOR=RED>receipt only if it has been carried out</FONT>. If it has not been done yet, it is necessary to postpone the date of reception and not to receive the order.<br />" & _
"<FONT COLOR=RED><b><u>Deadline : ASAP</u></b></FONT><br /><br />" & _
"<b><u>Recall n°2 :</u></b> The line and the brand must be entered in POs. There's still PO's without brand and line.<br /><br />" & _
"If you have any questions don't hesitate to come back to me,<br /><br />" & _
"Regards,"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
'Efface le fichier que vous avez envoyé
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Une boite de dialogue pour confirmer que l'email a bel et bien été envoyé
MsgBox Application.UserName & "," & vbCr & "Cette Feuille: " & ActiveSheet.Name & ", a été envoyée par email.", _
vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Envoie d'email"
End SubBonjour m3ellem1,
Ça fonctionne car ça envoie tous les mails. Cependant, après l'envoie de tous les mails mon fichier se bloque et l'erreur 400 apparait
;( et j'ai réessaie avec F5 et c'est l'erreur 1004 qui apparaît
Merci pour ton aide
à quelle ligne ca bloque?
je ne sais pas
Est ce que tu peux me dire comment on voit ça q'il te plait ?
Merci vraiment pour ton aide
avec F8 tu peux aller étape par étape, mais essaie de reduire le nbr de feuille à une comme ca tu finiras rapidement
Sinon tu crées un nouveau module et tu colle ton code et tu teste s'il te plaît.
Je pense avoir compris le problème,
En fait c'est le code
error go to 0 qui fait buguer le code car une fois qu'il fait tous les onglet que je veux envoyer il va sur celui de la base TCD qui n'a rien ce cellule B1 donc ça arrête la macro.
Est ce que tu sais comment on peut faire en sorte qu'il ne prenne pas les 3 derniers onglet dans le Mailling ?
Merci bcp
tu peux faire comme ca:
aprés ===> For Each sh In ThisWorkbook.Worksheets
ajoutes:
If sh.Name <> "TCD Global" And sh.Name <> "Extract SAP" And sh.Name <> "Mapping" Then
et avant ==> Next sh
ajoutes:
End If
sinon il y a moyen de faire ca avec
While Worksheets.Count > 3
'ton code ici
Wendpuisque c'est vraiment les 3 dernières feuilles
Il me met :
Erreur de compliation
Next sans FOR ;(
Pardon avnt pas aprés
j'ai corrigé en haut
Super ça marche.
Je voulais rajouter une dernière chose pour être sur que l'onglet mapping soit rempli et qu'il n'y ai pas d'oubli.
Mais du coup il me fait la même chose ;( même erreur
Le code est le suivant
'Determine la valeur en cellule B1 si correct pour le mailling
For Each sh In ThisWorkbook.Worksheets
If Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:D20"), 4, False) Like "" Then
MsgBox "Tab " & sh.Name & " incorrect " & vbLf & _
"Possible error :" & vbLf & _
"1) Username not fill out in the mapping tab." & vbLf & _
"2) Email not fill out in the mapping tab" & vbLf & _
" Please correct and try again. "
If Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:D20"), 4, False) Like "?*@?*.?*" Then
If sh.Name <> "TCD Global" And sh.Name <> "Extract SAP" And sh.Name <> "Mapping" Then
Vraiment super merci pour ton aide. Je comprends vraiment mieux pas mal de chose !!!
Re,
aprés ton IF il faut vraiment exclure les 3 derniéres feuilles. voici un test pour mieux comprendre:
Sub test()
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "TCD Global" And sh.Name <> "Extract SAP" And sh.Name <> "Mapping" Then
If Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:D20"), 4, False) Like "" Then
MsgBox "Tab " & sh.Name & " incorrect " & vbLf & _
"Possible error :" & vbLf & _
"1) Username not fill out in the mapping tab." & vbLf & _
"2) Email not fill out in the mapping tab" & vbLf & _
" Please correct and try again. "
End If
End If
Next sh
End Sub