Recherche dans un mailling VBA sur la ligne "to"

Le 19/03/2019 à 12:16

Re,

Merci ça fonctionne,

par contre ça n'envoie pas la feuille qui ne respecte pas toutes les condition mais il envoie toutes les autres alors que je cherchais à bloquer tous les envoies si un onglet et faux. sinon on en peut pas la refaire tourner sans tout renvoyer

Merci pour ton aide et ton temps

Le 19/03/2019 à 12:24

essaie comme ca

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.Name <> "TCD Global" And sh.Name <> "Extract SAP" And sh.Name <> "Mapping" Then
        If sh.Range("B1").Value Like "?*" Then
            If Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:B20"), 2, 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. "
             Else

'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:B20"), 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
        End If
        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
Le 19/03/2019 à 12:35

Là ça ne fonctionne plus du tout

Il bloque sur des onglets justes

erreur 91
Le 19/03/2019 à 12:41

j'ai besoin du code qui fonctionne mais qui ne respecte pas les conditions

car une fois tu fais un test avec ThisWorkbook.Sheets("Mapping").Range("A1:D20"), 4, False)

et aprés pour récupérer les adresses mail tu fais ThisWorkbook.Sheets("Mapping").Range("A1:B14"), 2, False)

alors je suis perturbé

Le 19/03/2019 à 12:45

C'est celui que tu m'as envoyé.

J'ai essayé d'adapter le mien mais il ne fonctionnait pas alors j'ai copié collé le tiens et c'est celui ci qui m'affiche ça

Le 19/03/2019 à 12:52

J'ai rectifié le code en haut.

c'était la ligne

Set OutApp = CreateObject("Outlook.Application")

je l'ai commenté sans me rendre compte

Le 19/03/2019 à 13:03

Re,

Ca envoie mais ça ne stop pas l'erreur et donc l'ensemble du mailling ;(

Le 19/03/2019 à 13:26

esct ce que ces codes fonctionnent separement ?

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:B20"), 2, 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
Sub test1()
'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.Name <> "TCD Global" And sh.Name <> "Extract SAP" And sh.Name <> "Mapping" Then
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
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
Le 19/03/2019 à 13:33

J'ai copié seulement ce code sans rien et oui il fonctionne Mais il affiche a la suite les erreurs donc je pense que la maccro continue aussi.

Le 19/03/2019 à 13:34

les deux fonctionnent? donc on a juste à les fusionner?

Le 19/03/2019 à 13:35

oui mais comme la macro continue ça sera surement le même problème.

J'ai besoin qu'à chaque erreur elle se bloque

Le 19/03/2019 à 13:42

c'est quel code qui te donne les erreurs? et quelle erreur 91?

Le 19/03/2019 à 13:46

Je veux que si la condition if est rempli (c'est à dire personne absente dans le mapping ou pas d'adresse mail )alors ca n'envoie pas de mail et bloque l'envoie de tous les onglets. Jusqu’à ce que l'onglet mapping soit juste, pour tout envoyer sans faire de faute ou d'oubli de mail ou de personne.

La dès qu'il y a un oublie il envoie les onglets suivants mais pas celui en erreur.

Donc si je veux corriger après il faut que je renvoie tout le classeur ;(

Le 19/03/2019 à 13:53

mais là on s'est mal compris!

donc l'envoi de mail ne doit se faire que si toutes les personnes ont une adresse mail valable! et si une seule adresse manque il s'arrête pourque tu puisse inserer/verifier l'adresse mail.

ok je comprend maintenant.

Le 19/03/2019 à 14:28
Sub test_2()
'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.Name <> "TCD Global" And sh.Name <> "Extract SAP" And sh.Name <> "Mapping" Then
    For Each sh1 In ThisWorkbook.Worksheets
        If sh1.Name <> "TCD Global" And sh1.Name <> "Extract SAP" And sh1.Name <> "Mapping" Then
        If Application.WorksheetFunction.VLookup(sh1.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:B20"), 2, False) Like "" Then
            MsgBox "Tab " & sh1.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. "
        Exit Sub
        End If
        End If
    Next sh1

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:B20"), 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
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
Le 20/03/2019 à 00:08

Super merci beaucoup ça fonctionne.

Est-ce que tu peux m'expliquer pourquoi tu mets 1 après chacune des Sheet ? et dans quel cas on peut le faire ?

En tout cas vraiment merci beaucoup pour ton aide et ton temps !!

Le 20/03/2019 à 00:53

Mais avec plaisir mon ami

car on l'a imbriqué sous la boucle For Each sh In ThisWorkbook.Worksheets

dans la variable sh garde la valeur de la première feuille jusqu'à ce que la boucle For Each sh1In ThisWorkbook.Worksheets finisse son travail.

en plus pour faire correctement il faut declarer sh1 en haut

Dim sh, sh1 As Worksheet
Le 20/03/2019 à 09:08

Bonjour m3ellem1,

Je viens de voir que j'ai besoin de rajouter encore une variable je suis désolé ;(

Si l'username dans l'onglet "Mapping" n'est pas renseigner il me met Erreur d'execution 1004 .

J'ai essaye de changer la colonne dans la recherche v pour mettre celle de la colonne de l'username mais ça ne fonctionne pas non plus ;(

Est ce que saurais comment faire par hasard, pour avoir les deux conditions séparés :

1) recherche de l'username cellule B1 de chaque sh dans l'onglet mapping colonne A si faux on arrête la macro avec message d'erreur pour username pas dans la macro

2) recherche de l'username cellule B1 de chaque sh dans l'onglet mapping colonne D pour voir la correspondance de l'adresse mail si faux on arrête la macro avec message d'erreur pour email pas dans la macro

Merci pour ton aide

Le 20/03/2019 à 18:18

Re,

C'est bon j'ai réussi !!!

Merci pour ton aide et tes explications je n'y serais pas arrivé sinon

Rechercher des sujets similaires à "recherche mailling vba ligne"