Recherche dans un mailling VBA sur la ligne "to" Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
J
JOKI75
Jeune membre
Jeune membre
Messages : 22
Appréciations reçues : 2
Inscrit le : 18 mars 2019
Version d'Excel : 2013

Message par JOKI75 » 18 mars 2019, 09:42

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: 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 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
m
m3ellem1
Membre impliqué
Membre impliqué
Messages : 1'812
Appréciations reçues : 162
Inscrit le : 18 décembre 2018
Version d'Excel : 2016

Message par m3ellem1 » 18 mars 2019, 10:09

Salut,

une question bête: ta feuille est ben nommée "Mapping" sans espace sans rien?
À partir d'hier, j'ai décidé de ne plus expliquer les solutions proposées et de ne plus répondre aux MP!
J
JOKI75
Jeune membre
Jeune membre
Messages : 22
Appréciations reçues : 2
Inscrit le : 18 mars 2019
Version d'Excel : 2013

Message par JOKI75 » 18 mars 2019, 10:11

salut,

Oui j'ai nommé l'onglet Mapping
m
m3ellem1
Membre impliqué
Membre impliqué
Messages : 1'812
Appréciations reçues : 162
Inscrit le : 18 décembre 2018
Version d'Excel : 2016

Message par m3ellem1 » 18 mars 2019, 10:36

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!
À partir d'hier, j'ai décidé de ne plus expliquer les solutions proposées et de ne plus répondre aux MP!
J
JOKI75
Jeune membre
Jeune membre
Messages : 22
Appréciations reçues : 2
Inscrit le : 18 mars 2019
Version d'Excel : 2013

Message par JOKI75 » 18 mars 2019, 10:38

Bonjour,

Voici le fichier
Relance MIGO designer Fragrance 0219 avec Macro test 2.xlsm
(104.97 Kio) Téléchargé 3 fois
m
m3ellem1
Membre impliqué
Membre impliqué
Messages : 1'812
Appréciations reçues : 162
Inscrit le : 18 décembre 2018
Version d'Excel : 2016

Message par m3ellem1 » 18 mars 2019, 11:21

change cette ligne:
If sh.Range("B1").Value Like "?*@?*.?*" Then
comme ca
If sh.Range("B1").Value <> "" Then
et fais un tests'il te plait. En attendant je regarde le code
À partir d'hier, j'ai décidé de ne plus expliquer les solutions proposées et de ne plus répondre aux MP!
J
JOKI75
Jeune membre
Jeune membre
Messages : 22
Appréciations reçues : 2
Inscrit le : 18 mars 2019
Version d'Excel : 2013

Message par JOKI75 » 18 mars 2019, 11:29

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 ?
m
m3ellem1
Membre impliqué
Membre impliqué
Messages : 1'812
Appréciations reçues : 162
Inscrit le : 18 décembre 2018
Version d'Excel : 2016

Message par m3ellem1 » 18 mars 2019, 11:43

JOKI75 a écrit :
18 mars 2019, 11:29
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.



JOKI75 a écrit :
18 mars 2019, 11:29
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 :mrgreen:
À partir d'hier, j'ai décidé de ne plus expliquer les solutions proposées et de ne plus répondre aux MP!
J
JOKI75
Jeune membre
Jeune membre
Messages : 22
Appréciations reçues : 2
Inscrit le : 18 mars 2019
Version d'Excel : 2013

Message par JOKI75 » 18 mars 2019, 12:01

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
m
m3ellem1
Membre impliqué
Membre impliqué
Messages : 1'812
Appréciations reçues : 162
Inscrit le : 18 décembre 2018
Version d'Excel : 2016

Message par m3ellem1 » 19 mars 2019, 08:31

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 Sub

À partir d'hier, j'ai décidé de ne plus expliquer les solutions proposées et de ne plus répondre aux MP!
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message