XL 2013 Envoyer un mail automatique avec le contenu de la bonne ligne

[mat123456]

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

 

[mat123456]

Voici le fichier

 

[Oneida]

Bonjour,

Sub Mail_auto_Text_Outlook()
    Dim xOutMail As Object
    Dim xMailBody As String
    
    Set xOutMail = CreateObject("Outlook.Application").CreateItem(0)
    With Worksheets("Suivi")
        Derlig = .Range("L" & .Rows.Count).End(xlUp).Row
        For i = 3 To Derlig
            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
    End With
    On Error GoTo 0
    Set xOutApp = Nothing