Envoi ligne Excel dans mail

Bonjour à tous,

Voici mon code vba qui fonctionne actuellement :

Sub envoi_mail()

Dim OL As Object, myItem As Object, wDoc As Object, rng As Object

Dim nb_lignes As Integer

Dim diffusion As String

diffusion = Range("I2")

Set OL = CreateObject("Outlook.Application")

Set myItem = OL.CreateItem(olMailItem)

Sheets("EVOL").Activate

With myItem

.Subject = "Diffusion Nouveaux Documents"

.To = "steph"

.Body = Chr(13) & Chr(10) & "Bonjour à tous," & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Veuillez prendre en compte la diffusion des documents ci-joint." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Merci."

.Display

Set wDoc = myItem.GetInspector.WordEditor

If diffusion = "" Then

Range("A2:H2").CopyPicture

wDoc.Application.Selection.Paste

End If

End With

Set OL = Nothing

Set myItem = Nothing

Set wDoc = Nothing

End Sub

Ce code permet d'envoyer un mail à Steph contenant un petit texte et la ligne A2 à H2 si dans la case I2, je n'ai pas de caractère. J'aimerai maintenant le modifier pour envoyer par mail toutes les lignes renseignées de mon tableau qui n'ont pas les caractères "OK" dans la colonne I.

Merci pour votre aide

Bonjour et

Pense à joindre un fichier pour la réponse.

Suggestion ...

Passe en htmlbody (et tu récupéreras aussi ta signature outlook)

Sub envoi_mail()

    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
    Dim nb_lignes As Integer
    Dim diffusion As String

    diffusion = Range("I2")
    Set OL = CreateObject("Outlook.Application")
    Set myItem = OL.CreateItem(olMailItem)

    Sheets("EVOL").Activate

        With myItem
            .Subject = "Diffusion Nouveaux Documents"
            .To = "steph"
            .htmlBody = "<br>Bonjour à tous,<br><br>Veuillez prendre en compte la diffusion des documents ci-joint.<br>" & tableau & "<br>Merci." & htmlBody
            .Display
        End With

        Set OL = Nothing
        Set myItem = Nothing
        Set wDoc = Nothing

End Sub

et ajoute cette fonction

Function tableau()
tableau = "<table>"
Dim i%, j%
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    If Range("I" & i) <> "OK" Then
        tableau = tableau & "<tr>"
        For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
            tableau = tableau & "<td>" & Cells(i, j) & "</td>"
        Next
        tableau = tableau & "</tr>"
    End If
Next
tableau = tableau & "</table>"
End Function

Bonjour à tous,

une autre solution possible:

Sub envoi_mail2()

    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
    Dim nb_lignes As Integer
    'Dim diffusion As String
    nb_lignes = Sheets("EVOL").Range("A" & Rows.Count).End(xlUp).Row

    ' diffusion = Range("I2")
    Set OL = CreateObject("Outlook.Application")
    Set myItem = OL.CreateItem(0)

    Sheets("EVOL").Activate

    With myItem
        .Subject = "Diffusion Nouveaux Documents"
        .To = "steph"
        .Body = Chr(13) & Chr(10) & "Bonjour à tous," & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Veuillez prendre en compte la diffusion des documents ci-joint." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Merci."
        .Display

        Set wDoc = myItem.GetInspector.WordEditor

        ActiveSheet.Range("$A$1:$I$" & nb_lignes).AutoFilter Field:=9, Criteria1:="="

        Range("A2:H" & nb_lignes).CopyPicture
        wDoc.Application.Selection.Paste

    End With

    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    Set OL = Nothing
    Set myItem = Nothing
    Set wDoc = Nothing

End Sub

Merci beaucoup, ça fonctionne parfaitement.