Envoyer un mail automatique avec le contenu de la bonne ligne

Bonjour,

J’ai besoin de votre aide, je débute en VBA, et j’ai créé un fichier Excel pour gérer les expéditions de l’atelier ou je travaille.

Lorsque l’on veut faire une expédition il suffit de remplir la première feuille « Expédition » et cliquer sur le bouton « Générer une expédition ». Ce qui va créer et remplit une ligne sur la deuxième feuille « Suivi » ainsi que remplir la 3e feuille « Etiquette » qui est une étiquette à coller sur le produit à expédier. En 4e feuille « Archivage » il y a un fichier qui est connecté à la base de données de l’entreprise et que ressence toutes les commandes. Lorsque sur la 2e feuille et la 3e il y a un numéro de commande qui coïncide la case « L » passe à « oui ». Ce qui doit envoyer un mail avec pour contenu le contenu des cellules « H » et « D » de la même ligne. Mais le problème est qu’à chaque fois le mail ne contient pas le bon message, il contient le contenu des cellules les plus basses où la case « L » contient « Oui ». Je vous joins un exemple car ce sera plus facile de comprendre pour vous.

Merci par avance de votre aide

Cordialement

Private Sub Worksheet_Calculate()
    Dim Zrg As Range
    Set Zrg = Range("L3:L1000000")
        If Not Intersect(Zrg, Range("L3:L1000000")) Is Nothing Then
            Call TestOutlookIsOpen
        End If
End Sub

Sub TestOutlookIsOpen()
    Dim oOutlook As Object

    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0

        If oOutlook Is Nothing Then
            MsgBox "Outlook n'est pas ouvert, ouvrer Outlook et ressayer"
            Call TestOutlookIsOpen
        Else
            Call Mail_auto_Text_Outlook
        End If

End Sub

Sub Mail_auto_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    For i = 3 To 1000000
        If Range("L" & i) = "Oui" Then
            designation = Range("H" & i)
            societe = Range("D" & i)
            xMailBody = "Bonjour," & vbNewLine & vbNewLine & _
              "Nous avont recu la pièce : (" & designation & ")." & vbNewLine & _
              "De la société " & societe & "." & vbNewLine & vbNewLine & _
              "Cordialement" & vbNewLine & vbNewLine & _
              "Ceci est un mail automatique merci de ne pas répondre."
        On Error Resume Next
            With xOutMail
                .To = "m*********.fr"
                .CC = ""
                .BCC = ""
                .Subject = "Expédition"
                .Body = xMailBody
                .Display   '.Send
            End With
        End If
    Next i
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing

End Sub

Sub expe_électro()

'Créer une nouvelle ligne + remplir le tableau de suivi

    Sheets("Suivi").Select
    Rows("4:4").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Sheets("Expédition").Select
    Range("A3:L3").Select
    Selection.Copy
    Sheets("Suivi").Select
    Range("A4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Expédition").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C3:J3").Select
    Application.CutCopyMode = False

    'Remplir la feuille "Etiquette"

    Worksheets("Expédition").Range("C3").Copy _
    Destination:=Worksheets("Etiquette").Range("C4")
    Worksheets("Expédition").Range("D3").Copy _
    Destination:=Worksheets("Etiquette").Range("C5")
    Worksheets("Expédition").Range("E3").Copy _
    Destination:=Worksheets("Etiquette").Range("C6")
    Worksheets("Expédition").Range("F3").Copy _
    Destination:=Worksheets("Etiquette").Range("C7")
    Worksheets("Expédition").Range("G3").Copy _
    Destination:=Worksheets("Etiquette").Range("C8")
    Worksheets("Expédition").Range("H3").Copy _
    Destination:=Worksheets("Etiquette").Range("C9")
    Selection.ClearContents

    'Copier la formule "Reçu"

    Sheets("Suivi").Select
    Range("L3").Copy Range("L4")

    'Imprimer

    'Sheets("Etiquette").PrintOut

End Sub

Bonjour,

Quand je lis ton code, je ne connais pas la feuille active, j'avais donc une possibilité d'erreur. A priori, ce n'est pas le cas...

Commence par supprimer "On Error Resume Next" pour voir si tu as un message d'erreur, normalement tu ne devrais pas avoir besoin de cette instruction et il se peut que ce soit cette ligne qui masque le problème : Normalement ton code est correct, la boucle se fait, donc il faut enlever la ligne "on error", pour voir ce qui ne va pas.

Apparemment l'envoi de mail se fait au recalcul de la feuille, ton programme repart de la ligne 3 et enverra donc toujours la ou les mêmes lignes. Tu peux corriger ce point en ajoutant une colonne "Mail envoyé" et en mettant la cellule de la ligne envoyé par mail à "Mail Ok" ou un truc du genre, sinon tu peux aussi remplacer le Oui de la colonne L à "Mail ok".

En plus On Error Goto 0 n'est pas au même niveau que le Resume Next, il est en dehors de la boucle, donc tu ne peux identifier aucune erreur après la ligne 3.

Tu peux aussi utiliser l'instruction "Stop" juste avant ".Display" identifier plus facilement l'erreur. Ensuite utilises F8 pour démarrer le pas à pas, tu devrais rapidement voir le problème. Si tu connais les espions (Dans VBE :Affichage/Fenêtre Espions), n'hésite pas à les utiliser ils sont toujours d'une aide précieuse même pour les utilisateurs confirmés.

Tu peux améliorer ton code en précisant le nom de la feuille pour laquelle ton code travaille plutôt que de faire des sélect, c'est plus propre et la lecture est plus facile à comprendre :

If Worksheets("Suivi").Range("L" & i) = "Oui" Then
            designation = Worksheets("Suivi").Range("H" & i)
            societe = Worksheets("Suivi").Range("D" & i)

Sinon tu peux aussi déclarer une variable de type Worksheet que tu charges, c'est un peu comme un alias :

Dim ShSuivi as Worksheet

Set ShSuivi = Worksheets("Suivi")

Ensuite il suffit d'utiliser la variable ShSuivi : ShSuivi.Range("H" & i)

Tu peux aussi utiliser l'instruction With, mais c'est pas évident de l'utiliser pour les débutants et généralement limitée à quelques dizaines de lignes de code :

With Worksheets("Suivi")

End With

Benead

Bonjour,

Merci de ta réponse rapide, mais ca ne marche toujours pas. Je pose un autre problème qui est que j'aimerais que lorsqu'un mail à était envoyer il ne puisse pas se renvoyer une 2e fois .

cordialement

Private Sub Worksheet_Calculate()
    Dim Zrg As Range
    Set Zrg = Range("L3:L1000000")
        If Not Intersect(Zrg, Range("L3:L1000000")) Is Nothing Then
            Call TestOutlookIsOpen
        End If
End Sub

Sub TestOutlookIsOpen()
    Dim oOutlook As Object

    Set oOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0

        If oOutlook Is Nothing Then
            MsgBox "Outlook n'est pas ouvert, ouvrer Outlook et ressayer"
            Call TestOutlookIsOpen
        Else
            Call Mail_auto_Text_Outlook
        End If

End Sub

Sub Mail_auto_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    For i = 3 To 1000000
        If Worksheets("Suivi").Range("L" & i) = "Oui" Then
            designation = Worksheets("Suivi").Range("H" & i)
            societe = Worksheets("Suivi").Range("D" & i)
            xMailBody = "Bonjour," & vbNewLine & vbNewLine & _
              "Nous avont recu la pièce : (" & designation & ")." & vbNewLine & _
              "De la société " & societe & "." & vbNewLine & vbNewLine & _
              "Cordialement" & vbNewLine & vbNewLine & _
              "Ceci est un mail automatique merci de ne pas répondre."
            With xOutMail
                .To = "matteo.croisier@laboulangere-co.fr"
                .CC = ""
                .BCC = ""
                .Subject = "Expédition"
                .Body = xMailBody
                .Display   '.Send
            End With
        End If
    Next i
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing

End Sub

Bonjour,

voici un fichier Excel qui représente la situation pour vous aider a comprendre le problème.

cordialement