Publipostage Multiligne via VBA

Question

Bonjour,

Cela fait plusieurs mois que je bloque sur un publipostage.
Je dois envoyer des commandes à plusieurs fournisseurs et aimerais faire un seul mail par fournisseur. Mes données sont regroupées et organisées dans un excel.
J'ai trouvé ce poste sur le forum qui m'a avancé https://forum.excel-pratique.com/excel/publipostage-multi-ligne-175227, mais je ne suis pas au bout

Joint mon fichier Test anonymisé, dans lequel j'ai les deux modules suivants :
Création des Mails :

Option Explicit

Sub publipostage()

    Application.ScreenUpdating = False

    Dim classeurOrigine As String, classeurPublipostage As String
    classeurOrigine = ActiveWorkbook.Name

    Workbooks.Add
    classeurPublipostage = ActiveWorkbook.Name
    [a1] = "Publipostage automatique réalisé le " & Format(Now, "dd/mm/yyyy hh:mm")

    Windows(classeurOrigine).Activate

    Dim table As Range
    Set table = [a1].CurrentRegion

    Dim ligne As Integer, colonne As Integer
    For ligne = 2 To table.Rows.Count
        Dim enregistrements As String, email As String
        enregistrements = ""

        For colonne = 1 To table.Columns.Count
            enregistrements = enregistrements & table(1, colonne) & ";" & table(ligne, colonne) & "!"
        Next

        Debug.Print Now, ligne, enregistrements

        ActiveSheet.Shapes(1).Copy
        Application.Wait (Now + TimeValue("0:00:01"))

        Windows(classeurPublipostage).Activate
        Sheets.Add After:=ActiveSheet

        ActiveSheet.Paste
        Application.CutCopyMode = False

        Dim enregistrement As Variant, nouveauTexte As String
        For Each enregistrement In Split(enregistrements, "!")
            If enregistrement <> "" Then
                nouveauTexte = ActiveSheet.Shapes(1).TextFrame.Characters.Text
                nouveauTexte = Replace(nouveauTexte, "[" & Split(enregistrement, ";")(0) & "]", Split(enregistrement, ";")(1), 1)
                ActiveSheet.Shapes(1).TextFrame.Characters.Text = nouveauTexte

                If Split(enregistrement, ";")(0) = "Mail" Then
                    email = Split(enregistrement, ";")(1)
                End If
            End If
        Next

        creerMail email, nouveauTexte

        Windows(classeurOrigine).Activate
    Next

    Application.ScreenUpdating = True

End Sub

Envoi des Mails :

Option Explicit

Sub creerMail(email As String, corps As String)

    Dim oOutlook As Object
    Set oOutlook = CreateObject("Outlook.Application")

    Dim oMail As Object
    Set oMail = oOutlook.CreateItem(0)

    With oMail
        .To = email
        .Body = corps
        .Subject = "Groupe XXX - Commandes Contractuelles"
        .Display
    End With
End Sub

Sauf que dans cette configuration j'ai un mail par ligne et non pas un mail par fournisseur.

Est-il possible de modifier le code pour solutionner ce problème ?

Merci d'avance

13test-publipostage-base-donnee.xlsm (39.27 Ko)

saboh12617 · Accepted Answer

Bon, avec un peu d'aide IA pour générer un tableau je suis arrivé à la révision de code ci-dessous.

Le seul problème que j'ai c'est que je n'arrive pas à extraire correctement le texte contenu dans la forme car : pour générer un tableau dans le mail il faut passer par le code HTML du mail. Cependant la shape contenant votre texte ne permet pas de récupérer le HTML correspondant à son formatage... Je verrai demain si je trouve une alternative, peut etre avec un Word encastré à la place de votre forme dans le document Excel.

Ci-après le nouveau code (lancez le sub PublipostageParFournisseur) :

Sub PublipostageParFournisseur()
    Dim table As Range
    Set table = [A1].CurrentRegion

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim headerRow As Range
    Set headerRow = table.Rows(1)

    ' Define relevant column headers
    Dim selectedHeaders As Variant
    selectedHeaders = Array( _
        "Numéro de Commande", "Site", "Nom du site", "Adresse du site", _
        "Prestation", "Montant", "Date début", "Adresse postale facture", _
        "Adresse dematerialisation facture", "Adresse mail relance facture" _
    )

    ' Map header names to column indices
    Dim headerMap As Object
    Set headerMap = CreateObject("Scripting.Dictionary")

    Dim colIndex As Long
    For colIndex = 1 To table.Columns.Count
        Dim headerName As String
        headerName = Trim(CStr(headerRow.Cells(1, colIndex).Value))
        If Not headerMap.exists(headerName) Then
            headerMap.Add headerName, colIndex
        End If
    Next colIndex

    ' Group rows by email
    Dim rowIndex As Long
    For rowIndex = 2 To table.Rows.Count
        Dim email As String
        email = CStr(table.Cells(rowIndex, 1).Value)

        Dim rowData() As Variant
        ReDim rowData(0 To UBound(selectedHeaders))

        Dim i As Long
        For i = 0 To UBound(selectedHeaders)
            Dim colNum As Long
            colNum = headerMap(selectedHeaders(i)) + 1
            rowData(i) = table.Cells(rowIndex, colNum).Value
        Next i

        Dim dataArray() As Variant
        If Not dict.exists(email) Then
            ReDim dataArray(0 To 0)
            dataArray(0) = selectedHeaders
            dict.Add email, Array(dataArray, 1)
        End If

        Dim currentData As Variant
        currentData = dict(email)
        dataArray = currentData(0)
        Dim nextIndex As Long
        nextIndex = currentData(1)

        ReDim Preserve dataArray(0 To nextIndex)
        dataArray(nextIndex) = rowData
        dict(email) = Array(dataArray, nextIndex + 1)
    Next rowIndex

    ' Send emails
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")

    Dim bodyTxt As String
    bodyTxt = ActiveSheet.Shapes(1).TextFrame.Characters.Text

    Dim emailK As Variant
    For Each emailK In dict.Keys
        dataArray = dict(emailK)(0)

        Dim htmlTable As String
        htmlTable = ArrayToHtml(WorksheetFunction.Transpose(WorksheetFunction.Transpose(dataArray)))

        Dim mailItem As Object
        Set mailItem = outlookApp.CreateItem(0)

        With mailItem
            .To = emailK
            .Subject = "Groupe XXX - Commandes Contractuelles"
            .htmlBody = "<html><body><p>" & bodyTxt & "</p>" & _
                        htmlTable & "<p>Cordialement,</p></body></html>"
            .Display
        End With
    Next emailK
End Sub

Private Function ArrayToHtml(arr As Variant) As String
    Dim htmlOutput As String
    htmlOutput = "<table style='border-collapse:collapse;border:1px solid #000;font-family:Calibri;font-size:11pt;'>"

    Dim isTwoDimensional As Boolean
    Dim rowCount As Long
    Dim colCount As Long

    ' Determine array dimensions
    On Error Resume Next
    colCount = UBound(arr, 2) - LBound(arr, 2) + 1
    If Err.Number = 0 Then
        isTwoDimensional = True
        rowCount = UBound(arr, 1) - LBound(arr, 1) + 1
    Else
        isTwoDimensional = False
        rowCount = 1
        colCount = UBound(arr) - LBound(arr) + 1
        Err.Clear
    End If
    On Error GoTo 0

    Dim rowIndex As Long
    For rowIndex = 0 To rowCount - 1
        htmlOutput = htmlOutput & "<tr>"

        Dim colIndex As Long
        For colIndex = 0 To colCount - 1
            Dim cellValue As String
            If isTwoDimensional Then
                cellValue = arr(rowIndex + LBound(arr, 1), colIndex + LBound(arr, 2))
            Else
                cellValue = CStr(arr(colIndex + LBound(arr)))
            End If

            Dim cellTag As String
            If rowIndex = 0 Then
                cellTag = "th"
            Else
                cellTag = "td"
            End If

            htmlOutput = htmlOutput & "<" & cellTag & _
                " style='border:1px solid #000;padding:4px;text-align:left;white-space:nowrap;'>" & _
                cellValue & "</" & cellTag & ">"
        Next colIndex

        htmlOutput = htmlOutput & "</tr>"
    Next rowIndex

    htmlOutput = htmlOutput & "</table>"
    ArrayToHtml = htmlOutput
End Function

saboh12617 · Accepted Answer

Ah oui effectivement ! J'avais mal compris. Avec des données fictives l'erreur ne m'était pas sauté aux yeux. Voici la correction (valeur de colNum ) : ' Group rows by email Dim rowIndex As Long For rowIndex = 2 To table.Rows.Count Dim email As String email = CStr(table.Cells(rowIndex, 1).Value) Dim rowData() As Variant ReDim rowData(0 To UBound(selectedHeaders)) Dim i As Long For i = 0 To UBound(selectedHeaders) Dim colNum As Long colNum = headerMap(selectedHeaders(i)) ' + 1 // ici il faut retirer le +1 rowData(i) = table.Cells(rowIndex, colNum).Value Next i...

saboh12617 · Answer

Et quelle "présentation" voulez-vous pour les infos à regrouper : Simple : 1 ligne par numéro de commande et les infos simplement mises cotes à cotes ? (je saurai le faire) Complexe : principe similaire mais mis en page dans un tableau (je ne saurai pas le faire) Doit-on garder les crochets ? Êtes-vous bien sur Windows ? Car l'utilisation des dictionnaires est une méthode simple et efficace pour regrouper par adresse email. Je n'ai pas trop compris pourquoi votre code navigue entre des classeurs ? Il me semble qu'on puisse tout faire avec le classeur courant...

saboh12617 · Answer

Merci pour votre retour. En réalité c'est cette partie du code qui est en cause : Dim selectedHeaders As Variant selectedHeaders = Array( _ "Numéro de Commande", "Site", "Nom du site", "Adresse du site", _ "Prestation", "Montant", "Date début", "Adresse postale facture", _ "Adresse dematerialisation facture", "Adresse mail relance facture" _ ) La macro va ensuite automatiquement chercher dans la feuille où se trouvent ces en-têtes. Donc pour changer l'ordre d'affichage dans le mail, changez le ici. PS : Attention aux majuscules/minuscules/accents/espaces ! Si vous regardez j'ai repris la liste entre crochets qui était en fin de mail, c'est pour ça...

saboh12617 · Answer

Je vous en prie, content d'avoir pu vous faire avancer, j'ai moi aussi appris des choses. Bonne journée et au plaisir...