Envoyer des tableaux automatisés par outlook

Bonjour,

Je n'ai pas trouvé ma réponse sur le forum, bien qu'un sujet s'en approche beaucoup, il ne semble pas fonctionner dans mon cas et génère des erreurs quand j'essaie de le modifier. Voici cependant le lien vers le fil si cela peut aider :https://forum.excel-pratique.com/excel/envoyer-tableau-par-mail-dans-le-corps-du-texte-plusieurs-des...

J'ai un tableau Excel de plusieurs milliers de lignes avec en colonnes :

Prénom / Nom / identifiant / adresse mail de contact

J'ai plus de 300 adresses mails de contacts et souhaite que chacun d'entre eux reçoivent un mail qui reprendrait dans le corps du texte, un tableau qui contiendrait leurs Prénom / nom / identifiant.

Plus clairement, mon tableau Excel ressemble à cela :

J'aimerai que "a@ab.fr" reçoivent un mail du type :

"Bonjour,

blablabla,

voici votre tableau :

Cordialement,

Votre boss"

et bien sur "b@ab.fr" et tous les autres devraient recevoir le tableau qui les concerne.

Nous utilisons la suite office 2016.

Merci d'avance pour votre aide ! Je ne saurai assez vous remercier.

Je précise cependant que bien que je sache créer et utiliser des macros par enregistrement, je suis TOTALEMENT :) novice en VBA. Merci pour votre indulgence.

Marc

Bonjour Marc et le forum,

J'ai adapté le code que j'avais proposé sur ce même forum il y a quelques jours, vois si cela te convient (à changer .Display en .Send après la phase le test):

Sub mailMarc()
'https://forum.excel-pratique.com/excel/envoyer-des-tableaux-automatises-par-outlook-192321

    Dim OutApp As Object, OutMail As Object
    Dim myRng As Range, v As Variant
    Dim j As Long, lastRow As Long
    Dim strbody As String

    Application.ScreenUpdating = False

    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:D" & lastRow).Value
    strbody = "Bonjour ," & "<br>" & _
                  "voici votre tableau :" & "<br/><br>"

    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(v)
            If Not .exists(v(j, 4)) Then
                .Add v(j, 4), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 4, v(j, 4)
                    Set myRng = .Range("A1:D" & lastRow).SpecialCells(xlCellTypeVisible)

                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = v(j, 4)
                        .Subject = "Recap"
                        .HTMLBody = strbody & RangetoHTML(myRng) & "<br>Cordialement," & "<br>" & "Votre boss"
                        .Display
                       ' .Send
                    End With
                End With
            End If
        Next j

    End With

    Range("A1").AutoFilter

    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(myRng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim i      As Integer

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    myRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i
    End With

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")

    With TempWB
    .Close savechanges:=False
    End With

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Cordialement

Bonjour,

Un grand merci ! Votre proposition est tout à fait exceptionnelle et marche à la perfection !

S'il fallait pousser un peu plus loin :

- nous utilisons plusieurs comptes de messagerie dans Outlook, est-il possible qu'un de ces comptes soit défini comme émetteur ?

- si je souhaite que la colonne "adresse mail de contact" n'apparaisse pas dans le mail, comme faire ? j'ai essayé de modifié la colonne "D" par "C", mais cela provoque des bugs.

Encore une fois merci, car même si vous n'allez pas plus loin votre code répond déjà à ma demande !

Marc

Bonjour Marc,

merci pour ton retour, il faut changer la colonne seulement dans la ligne suivante:

Set myRng = .Range("A1:C" & lastRow).SpecialCells(xlCellTypeVisible)

Pour chosir l'adresse ajoute avant la ligne

.Display 'or .Send

cette ligne, à adapter l'adresse

Set .SendUsingAccount = .Session.Accounts.Item("monclub@mail.com")

Cordialement

Merci, tout fonctionne désormais !

Merci pour le temps passé sur ce sujet qui j'espère aidera d'autres personnes.

Bonjour Marc,

merci de passer les sujet en "Résolu"