XL 2013 (RESOLU) Automatisation de la Saisie de Données Excel vers un Document Word Modèle

chaelie2015

XLDnaute Accro
Bonsoir Forum
J'ai un fichier Word que j'utilise comme modèle de document, appelé, "Charlie doc type". Dans ce document, il y a un texte qui comprend plusieurs contrôles de contenu de texte enrichi que j'ai nommés comme suit : "Champs_Nom" (il y en a trois), "Champs_Prénom" (il y en a trois également), et "Champs_Date" (il y en a trois aussi).

Par ailleurs, j'ai un fichier Excel (Feuille1) qui contient un tableau avec deux colonnes (A et B) et quatre lignes. La première ligne contient les en-têtes du tableau. Plus précisément,

je souhaite que les valeurs saisies dans les cellules du tableau A1:B4 de ce fichier Excel soient automatiquement renseignées dans les contrôles de contenu correspondants du document Word. Pour être plus précis, la cellule B2 du tableau Excel contient le nom, la cellule B3 contient le prénom, et la cellule B4 contient une date que je souhaite transmettre au document Word.
Merci
 

Pièces jointes

  • Charlie doc type.docx
    18.8 KB · Affichages: 14
  • Charlie Excel vers Word.xlsx
    11.6 KB · Affichages: 15
Dernière édition:
Solution
En fait pour traiter votre pied de page ce n'est pas très compliqué :
VB:
Sub Word()
Dim Wapp As Object, Wdoc As Object, c As Object, n&
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Set Wdoc = Wapp.Documents.Open(ThisWorkbook.Path & "\Charlie doc type.docx")
For Each c In Wdoc.ContentControls
    c.Range.Text = Format(Application.VLookup(c.Title, Range("A2:B4"), 2, 0), "dd/mm/yyyy")
Next
For Each c In Wdoc.Sections(1).Footers(1).Range.ContentControls
    c.Range.Text = Format(Application.VLookup(c.Title, Range("A2:B4"), 2, 0), "dd/mm/yyyy")
Next
Wdoc.Sections(1).Footers(1).Range.Text = Replace(Wdoc.Sections(1).Footers(1).Range.Text...

job75

XLDnaute Barbatruc
Bonjour chaelie2015, le forum,

Téléchargez les fichiers joints dans le même dossier.

La macro affectée au bouton :
VB:
Sub Word()
Dim Wapp As Object, Wdoc As Object, c As Object
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Set Wdoc = Wapp.Documents.Open(ThisWorkbook.Path & "\Charlie doc type.docx")
For Each c In Wdoc.ContentControls
    c.Range.Text = Application.VLookup(c.Title, Range("A2:B4"), 2, 0)
Next
AppActivate Wapp.Caption
End Sub
En A3 il y avait un espace superflu et il manquait un s !

En A4 il faut un n à la place du m comme dans le doc Word !

A+
 

Pièces jointes

  • Charlie doc type.docx
    18.8 KB · Affichages: 6
  • Charlie Excel vers Word.xlsm
    20.1 KB · Affichages: 7

chaelie2015

XLDnaute Accro
Bonjour chaelie2015, le forum,

Téléchargez les fichiers joints dans le même dossier.

La macro affectée au bouton :
VB:
Sub Word()
Dim Wapp As Object, Wdoc As Object, c As Object
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Set Wdoc = Wapp.Documents.Open(ThisWorkbook.Path & "\Charlie doc type.docx")
For Each c In Wdoc.ContentControls
    c.Range.Text = Application.VLookup(c.Title, Range("A2:B4"), 2, 0)
Next
AppActivate Wapp.Caption
End Sub
En A3 il y avait un espace superflu et il manquait un s !

En A4 il faut un n à la place du m comme dans le doc Word !

A+
Bonjour Job, Forum
Extraordinaire comme toujours, nous te saluons pour ton excellence.
Je souhaite encore d'incorporer au code la capacité de créer une copie du document Word (conforme au document word type) pendant le transfert de données d'Excel vers Word, et de le nommer en fonction des contenus des cellules A2 et A4.
Ensuite, je souhaite supprimer les contrôles de contenu dans ce nouveau document Word créé.
Merci
 

job75

XLDnaute Barbatruc
VB:
Sub Word()
Dim Wapp As Object, Wdoc As Object, c As Object, n&
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Set Wdoc = Wapp.Documents.Open(ThisWorkbook.Path & "\Charlie doc type.docx")
For Each c In Wdoc.ContentControls
    c.Range.Text = Format(Application.VLookup(c.Title, Range("A2:B4"), 2, 0), "dd/mm/yyyy")
Next
Err = 0
Wdoc.SaveAs ThisWorkbook.Path & "\" & Range("B2") & " " & Format(Range("B4"), "dd mm yyyy") & ".docx"
If Err = 0 Then
    For n = Wdoc.ContentControls.Count To 1 Step -1
        Wdoc.ContentControls(n).Delete
    Next
End If
AppActivate Wapp.Caption
End Sub
 

Pièces jointes

  • Charlie doc type.docx
    18.8 KB · Affichages: 7
  • Charlie Excel vers Word.xlsm
    21.3 KB · Affichages: 7

chaelie2015

XLDnaute Accro
VB:
Sub Word()
Dim Wapp As Object, Wdoc As Object, c As Object, n&
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Set Wdoc = Wapp.Documents.Open(ThisWorkbook.Path & "\Charlie doc type.docx")
For Each c In Wdoc.ContentControls
    c.Range.Text = Format(Application.VLookup(c.Title, Range("A2:B4"), 2, 0), "dd/mm/yyyy")
Next
Err = 0
Wdoc.SaveAs ThisWorkbook.Path & "\" & Range("B2") & " " & Format(Range("B4"), "dd mm yyyy") & ".docx"
If Err = 0 Then
    For n = Wdoc.ContentControls.Count To 1 Step -1
        Wdoc.ContentControls(n).Delete
    Next
End If
AppActivate Wapp.Caption
End Sub
Re
C'est excellent, une fois de plus merci pour vos réponses.
A+
 

chaelie2015

XLDnaute Accro
Bonsoir JOB , Forum
Un autre problème est survenu avec les contrôles situés dans le pied de page de la feuille Word. Lorsque j'applique un contrôle de contenu identique, nommé "Champs_date", à la fois sur la feuille Word et dans le pied de page, le macro affiche correctement le contrôle présent sur la feuille, mais il ne semble pas afficher celui qui est situé dans le pied de page.
Merci par avance
 
Dernière édition:

mromain

XLDnaute Barbatruc
Bonjour chaelie2015, job75 le forum,

Ci-dessous le code retouché (mais pas testé) de job pour prendre en compte également les contrôles de contenu des entêtes et pieds de pages :
VB:
Sub Word()
Dim Wapp As Object, Wdoc As Object, c As Object, n&, collCc As Collection
    On Error Resume Next
    Set Wapp = GetObject(, "Word.Application")
    If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
    On Error GoTo 0
    Wapp.Visible = True
    Set Wdoc = Wapp.Documents.Open(ThisWorkbook.Path & "\Charlie doc type.docx")
    Set collCc = GetDocumentContentControls(Wdoc)
    For n = collCc.Count To 1 Step -1
        Set c = collCc.Item(n)
        c.Range.Text = Format(Application.VLookup(c.Title, Range("A2:B4"), 2, 0), "dd/mm/yyyy")
        c.Delete
    Next
    Wdoc.SaveAs ThisWorkbook.Path & "\" & Range("B2") & " " & Format(Range("B4"), "dd mm yyyy") & ".docx"
    AppActivate Wapp.Caption
End Sub


'Private Function GetDocumentContentControls(p_o_wdDoc As Word.Document) As VBA.Collection
Private Function GetDocumentContentControls(p_o_wdDoc As Object) As VBA.Collection
Dim l_o_wdSection  As Object  'Word.Section
Dim l_o_wdHf        As Object  'Word.HeaderFooter
Dim l_o_wdCc        As Object  'Word.ContentControl
    Set GetDocumentContentControls = New VBA.Collection
    For Each l_o_wdCc In p_o_wdDoc.ContentControls
        GetDocumentContentControls.Add l_o_wdCc
    Next l_o_wdCc
    For Each l_o_wdSection In p_o_wdDoc.Sections
        For Each l_o_wdHf In l_o_wdSection.Headers
            For Each l_o_wdCc In l_o_wdHf.Range.ContentControls
                GetDocumentContentControls.Add l_o_wdCc
            Next l_o_wdCc
        Next l_o_wdHf
        For Each l_o_wdHf In l_o_wdSection.Footers
            For Each l_o_wdCc In l_o_wdHf.Range.ContentControls
                GetDocumentContentControls.Add l_o_wdCc
            Next l_o_wdCc
        Next l_o_wdHf
    Next l_o_wdSection
End Function

A+
 

chaelie2015

XLDnaute Accro
Bonjour mromain, Job75 el forum
Je vous remercie d'avoir répondu, cependant, je fais face à une erreur d'exécution '13' : Incompatibilité de type, qui survient à la ligne suivante : "c.Range.Text = Format(Application.VLookup(c.Title, Range("A2:B6"), 2, 0), "dd/mm/yyyy")".
NB: De plus, il n'effectue le transfert que pour les contrôles de contenu situés dans les en-têtes et les pieds de page. o_O
A+
 
Dernière édition:

mromain

XLDnaute Barbatruc
Re-bonjour,

J'ai bien eu la même erreur que toi.
Cela vient de problèmes de cohérence entre le nom des contrôles de contenu dans le modèle Word et dans le fichier Excel.

Ci-dessous un autre code, plus "lourd", mais qui donnera des messages d'erreur plus explicites :
VB:
Public Sub GenerateWord()
Dim l_o_wdDoc          As Object  'Word.Document
Dim l_l_i              As Long
Dim l_s_pathNewFile    As String
Dim l_o_collCc          As VBA.Collection
Dim l_o_dicoCc          As Object  'Scripting.Dictionary
    
    'créer un nouveau document
    Set l_o_wdDoc = CreateDocFromTemplate(ThisWorkbook.Path & "\Charlie doc type.docx")
    'récupérer les contrôles de contenus
    Set l_o_collCc = GetAllDocumentContentControls(l_o_wdDoc)
    'trier les contrôles de contenus
    Set l_o_dicoCc = GetDicoContentContolsByTitle(l_o_collCc)
    
    'renseigner les contrôles de contenu
    With Feuil1
        For l_l_i = 2 To 4
            WriteInContentControls l_o_dicoCc, .Cells(l_l_i, "A").Value, .Cells(l_l_i, "B").Value
        Next l_l_i
    End With
    
    'supprimer les contrôles de contenu du document
    For l_l_i = l_o_collCc.Count To 1 Step -1
        l_o_collCc.Item(l_l_i).Delete
    Next l_l_i
    
    'enregistrer le document
    l_o_wdDoc.SaveAs ThisWorkbook.Path & "\" & Range("B2") & " " & Format(Range("B4"), "dd mm yyyy") & ".docx"
    
    MsgBox "Document généré.", vbInformation, "Info"
    
    Set l_o_wdDoc = Nothing
    Set l_o_dicoCc = Nothing
    Set l_o_collCc = Nothing
End Sub


'fonction dédiée à créer un document Word à partir d'un modèle
'Private Function CreateDocFromTemplate(p_s_pathTemplate As String, Optional p_o_wdApp As Word.Application = Nothing) As Word.Document
Private Function CreateDocFromTemplate(p_s_pathTemplate As String, Optional p_o_wdApp As Object = Nothing) As Object
Static s_o_fso  As Object      'Scripting.FileSystemObject
Dim l_o_wdApp  As Object      'Word.Application
    'vérifier si le modèle de document existe
    If s_o_fso Is Nothing Then Set s_o_fso = CreateObject("Scripting.FileSystemObject")
    If Not s_o_fso.FileExists(p_s_pathTemplate) Then Err.Raise vbObjectError, , "Le modèle de document '" & p_s_pathTemplate & "' n'a pas été trouvé."
    'gérer l'instance Word (soit utiliser celle passée en paramètre, soit récupérer celle ouverte, soit en créer une nouvelle)
    If p_o_wdApp Is Nothing Then
        On Error Resume Next
        Set l_o_wdApp = GetObject(, "Word.Application")
        If l_o_wdApp Is Nothing Then Set l_o_wdApp = CreateObject("Word.Application")
        On Error GoTo 0
        If l_o_wdApp Is Nothing Then Err.Raise vbObjectError, , "Impossible d'ouvrir Word."
        l_o_wdApp.Visible = True
    Else
        Set l_o_wdApp = p_o_wdApp
    End If
    Set CreateDocFromTemplate = l_o_wdApp.Documents.Add(p_s_pathTemplate)
    Set l_o_wdApp = Nothing
End Function

'fonction dédiée à trier les contrôles de contenu par titre (les contrôles de contenu sans titres sont ignorés)
'ils sont retourné dans un dictionnaire :
'  - clef : titre du contrôle de contenu
'  - valeur : VBA Collection contenant tous les contrôles de contenu ayant ce titre
Private Function GetDicoContentContolsByTitle(p_o_collWdCc As VBA.Collection) As Object  'Scripting.Dictionary
Dim l_o_wdCc    As Object  'Word.ContentControl
    Set GetDicoContentContolsByTitle = CreateObject("Scripting.Dictionary")
    GetDicoContentContolsByTitle.CompareMode = 1      '1 = Scripting.CompareMethod.TextCompare
    For Each l_o_wdCc In p_o_collWdCc
        If Not l_o_wdCc.Title Like vbNullString Then
            If Not GetDicoContentContolsByTitle.Exists(l_o_wdCc.Title) Then GetDicoContentContolsByTitle.Add l_o_wdCc.Title, New VBA.Collection
            GetDicoContentContolsByTitle.Item(l_o_wdCc.Title).Add l_o_wdCc
        End If
    Next l_o_wdCc
    Set l_o_wdCc = Nothing
End Function

'procédure dédiée à renseigner les controles de contenu partageant le même titre
'Private Sub WriteInContentControls(p_o_dicoContentControls As Scripting.Dictionary, p_s_ccTitle As String, p_v_value As Variant)
Private Sub WriteInContentControls(p_o_dicoContentControls As Object, p_s_ccTitle As String, p_v_value As Variant)
Dim l_o_wdCc    As Object  'Word.ContentControl
    'vérifier qu'il existe bien un ou plusieurs contrôles de contenu avec ce titre
    If Not p_o_dicoContentControls.Exists(p_s_ccTitle) Then Err.Raise vbObjectError, , "Aucun contrôle de contenu ayant pour titre '" & p_s_ccTitle & "' n'a été trouvé dans le document."
    For Each l_o_wdCc In p_o_dicoContentControls.Item(p_s_ccTitle)
        l_o_wdCc.Range.Text = p_v_value
    Next l_o_wdCc
    Set l_o_wdCc = Nothing
End Sub

'procédure dédiée à récupérer les contrôles de contenu d'un document (dans le corps du document, les entêtes et les pieds de pages)
'Private Function GetAllDocumentContentControls(p_o_wdDoc As Word.Document) As VBA.Collection
Private Function GetAllDocumentContentControls(p_o_wdDoc As Object) As VBA.Collection
Dim l_o_wdSection  As Object  'Word.Section
Dim l_o_wdHf        As Object  'Word.HeaderFooter
Dim l_o_wdCc        As Object  'Word.ContentControl
    Set GetAllDocumentContentControls = New VBA.Collection
    For Each l_o_wdCc In p_o_wdDoc.ContentControls
        GetAllDocumentContentControls.Add l_o_wdCc
    Next l_o_wdCc
    For Each l_o_wdSection In p_o_wdDoc.Sections
        For Each l_o_wdHf In l_o_wdSection.Headers
            For Each l_o_wdCc In l_o_wdHf.Range.ContentControls
                GetAllDocumentContentControls.Add l_o_wdCc
            Next l_o_wdCc
        Next l_o_wdHf
        For Each l_o_wdHf In l_o_wdSection.Footers
            For Each l_o_wdCc In l_o_wdHf.Range.ContentControls
                GetAllDocumentContentControls.Add l_o_wdCc
            Next l_o_wdCc
        Next l_o_wdHf
    Next l_o_wdSection
    Set l_o_wdSection = Nothing
    Set l_o_wdHf = Nothing
    Set l_o_wdCc = Nothing
End Function


A+
 

chaelie2015

XLDnaute Accro
Re
Je regrette, mais une autre erreur d'exécution s'est produite, avec le code '2147221504(80040000)' : Aucun contrôle de contenu ayant pour titre "n'a été trouvé dans le document". Cette erreur a été générée à la ligne suivante du code : Err.Raise vbObjectError, , 'Aucun contrôle de contenu portant le titre '" & p_s_ccTitle & "' n'a été trouvé dans le document.'
Merci
 

mromain

XLDnaute Barbatruc
Re-bonjour,

Vu le message d'erreur, cela signifie que, au niveau de la ligne WriteInContentControls l_o_dicoCc, .Cells(l_l_i, "A").Value, .Cells(l_l_i, "B").Value, tu essaye de modifier un contrôle de contenu sans spécifier le titre de celui-ci.
Ta cellule .Cells(l_l_i, "A") doit être vide.

Sinon, difficile de t'aider sans voir quels sont exactement les fichier sur lesquels tu travailles...

A+
 

job75

XLDnaute Barbatruc
Bonjour chaelie2015, mromain, le forum,

Je ne comprends pas bien.

S'il s'agit d'entrer la date de La cellule B4 dans le pied de page Word ajoutez :
VB:
Wdoc.Sections(1).Footers(1).Range.Text = Format(Range("B4"), "dd/mm/yyyy") 'pied de page
A+
 

Pièces jointes

  • Charlie doc type.docx
    27 KB · Affichages: 6
  • Charlie Excel vers Word.xlsm
    21.6 KB · Affichages: 5

chaelie2015

XLDnaute Accro
Bonjour Job75, mromain, le forum
@ Job75 : Je vous suis extrêmement reconnaissant, cependant, il est important de noter qu'il y a du texte dans les en-têtes ou pieds de page.
Par exemple, dans le pied de page, j'ai le texte suivant : 'PV n° ___ - 2023 (champ date automatique) - le contrôle de contenu (date). Page 1/1.' Je préférerais que ce texte ne soit pas supprimé.
ci joint le fichier exemple.
Merci

 

Pièces jointes

  • Charlie doc type.docx
    22 KB · Affichages: 9
  • Charlie Excel vers Word.xlsm
    19.6 KB · Affichages: 9

Discussions similaires

Statistiques des forums

Discussions
312 817
Messages
2 092 367
Membres
105 380
dernier inscrit
ASea DSea