J'ai réalisé ma macro de mailing 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.
Je souhaite qu'il aille cherche la cellule B1 dans chaque onglet et qu'il prenne la correspondance avec une recherche V sur l'onglet Mapping.
J'ai tout essayé mais la recherche ne 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
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 = ""
.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 & "Ce Classeur: " & ActiveSheet.Name & ", a été envoyée par email.", _
vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Envoie d'email"
End Sub
Merci pour votre aide !
Configuration: Windows / Chrome 72.0.3626.121
A voir également:
Intégréer une fonction Vlookup dans le "to" d'un mail
18 mars 2019 à 12:16
c'est sur la partie
If sh.Range("B1").Value Like "?*@?*.?*" Then
Il fallait mettre
If sh.Range("B1").Value <> "" Then
Merci