XL 2021 Transfert tableau structuré EXCEL à un endroit précis de WORD

BARNS · 12 Mars 2024

Bonjour à tous,

Je sollicite vos lumières pour avancer sur un code VBA permettant l'échange d'information entre Excel et Microsoft Word. (je pense que ce genre d'outils pourra servir à d'autres, j'ai anonymisé les informations sur les deux fichiers en PJ WORD et BDD EXCEL )

Le contexte : je dois créer un outil excel qui soit capable de générer des offres sous word à partir d'un ensemble de données.

Les différents types de données :
– les tables, elles ont pour objectifs selon le besoin d'être filtrées pour après récupéré certaines données filtrer pour les envoyer sous WORD (feuille : "SOLUTION", "REF_ECF")
– les champs remplis de manière spécifique permettront aussi de compléter des champs sous word.

Pour l'instant j'ai réussi à :
– pouvoir remplir des champs word via excel (feuille : "CADRAGE") cf macro EXT_CHAMP
– filtrer et extraire les éléments d'un tableau (feuille : "REF") cf macro EXT_REF vers une autre feuille REF_EXT

Mais je n'arrive pas à prendre le tableau généré et l'envoyer dans word tentative avec la macro "EXT_TAB_WORD" et c'est sur ce dernier point que j'aimerai avoir de l'aide si possible.

L'objectif est d'envoyer le tableau "BDD_REF_EXT" de la feuille "REF_ECF_EXT" vers le word après la phrase "Silicium et nostradae cubitus."

J'ai différents messages d'erreur, je ne sais pas si le code arrive à :
– sélectionner l'objet tab "BDD_REF_EXT" et le copier ;
– positionner le curseur.

Le code en question :

Sub ExportToWordAfterPhraseWithExistingFile()
Dim wdApp As Object 'Objet Word.Application
Dim wdDoc As Object 'Objet Word.Document
Dim ws As Worksheet
Dim tbl As ListObject
Dim rng As Range ' Plage de destination dans Word
Dim findPhrase As String ' Phrase à rechercher dans le document Word
Dim nom_fichier As Variant ' Nom du fichier Word existant

' Sélectionner le fichier Word existant
nom_fichier = Application.GetOpenFilename("Word files (*.docx), *.docx")
If nom_fichier = "Faux" Then
MsgBox "Aucun fichier sélectionné. Exportation annulée."
Exit Sub
End If

' Créer une nouvelle instance de Word
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True ' Afficher Word

' Ouvrir le document Word existant
Set wdDoc = wdApp.Documents.Open(nom_fichier)

' Rechercher la phrase dans le document Word
findPhrase = "Silicium et nostradae cubitus."
With wdDoc.Range
If .Find.Execute(findPhrase) Then
' Définir le curseur juste après la phrase trouvée
.Collapse Direction:=wdCollapseEnd
' Set rng = ActiveDocument.Content
Else
MsgBox "Phrase introuvable dans le document Word. Exportation annulée."
wdDoc.Close False ' Fermer le document Word sans enregistrer les modifications
Exit Sub
End If
End With

' Définir la plage de destination après la phrase

' Boucler à travers toutes les feuilles du classeur Excel
For Each ws In ThisWorkbook.Worksheets
' Vérifier si le tableau "tab" existe dans la feuille
On Error Resume Next
Set tbl = ws.ListObjects("BDD_REF_EXT")
On Error GoTo 0

If Not tbl Is Nothing Then
' Copier le tableau "tab" dans Excel
tbl.Range.Copy
With wdDoc.Range
' Coller le tableau dans Word juste après la phrase spécifiée
.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False ' Coller le tableau sans conserver les liens Excel

' Insérer un saut de page après le tableau
' rng.Collapse Direction:=0 ' Déplacer le curseur au début de la plage de destination
'rng.Move wdParagraph, 1 ' Aller à la ligne suivante
End With
Else
MsgBox "Le tableau ""tab"" n'a pas été trouvé dans la feuille de calcul. Exportation annulée."
wdDoc.Close False ' Fermer le document Word sans enregistrer les modifications
Exit Sub
End If
Next ws

' Informer l'utilisateur que l'exportation est terminée
MsgBox "Exportation vers Word terminée avec succès !"

' Enregistrer les modifications et fermer le document Word
wdDoc.Save
wdDoc.Close

Set wdDoc = Nothing

End Sub

Merci pour votre précieuse aide,

job75 · 12 Mars 2024

Bonjour BARNS,

BARNS à dit:
L'objectif est d'envoyer le tableau "BDD_REF_EXT" de la feuille "REF_ECF_EXT" vers le word après la phrase "Silicium et nostradae cubitus."

Pas trouvé cette phrase dans le doc Word.

A+

BARNS · 13 Mars 2024

Oupsy, je viens de MAJ le fichier.

job75 · 13 Mars 2024

Bonjour BARNS, le forum,

Voici une solution, si j'ai bien compris ce qu'il faut faire :

VB:

Sub Coller_dans_Word()
Dim Wapp As Object, texte$, L%, Wdoc As Object, i&, j&
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
On Error GoTo 0
If Wapp Is Nothing Then MsgBox "Ouvrez le document Word": Exit Sub
texte = "Silicium et nostradae cubitus."
L = Len(texte)
Set Wdoc = Wapp.ActiveDocument
For i = 0 To Len(Wdoc.Content)
    If Wdoc.Range(i, i + L) = texte Then Exit For
Next i
If i > Len(Wdoc.Content) Then MsgBox "Texte non trouvé !": Exit Sub
For j = 1 To Wdoc.Tables.Count
    If Wdoc.Tables(j).Range.Start > i Then
        Wdoc.Tables(j).Select
        Wdoc.Tables(j).Delete
        [Tableau5].ListObject.Range.Copy 'copie le tableau structuré
        Wapp.Selection.Paste 'coller
        Application.CutCopyMode = 0
        Exit For
    End If
Next j
Wdoc.Range(0, 0).Select
AppActivate Wapp.Caption 'facultatif, active Word
End Sub

La copie du tableau Excel remplace le tableau Word situé sous le texte.

A+

job75 · 13 Mars 2024

Chez moi la dernière instruction est sans effet, Word ne s'active pas, et chez vous ?

job75 · 13 Mars 2024

Bon il faut ajouter True :

VB:

AppActivate Wapp.Caption, True 'facultatif,active Word

job75 · 13 Mars 2024

Bon ça a marché et maintenant ça ne marche plus !

job75 · 14 Mars 2024

Bonjour le forum,

J'ai compris, la fenêtre Word était réduite, il faut l'agrandir :

VB:

AppActivate Wapp.Caption, True 'facultatif, active Word
Wdoc.ActiveWindow.WindowState = 1 'wdWindowStateMaximize

A+

job75 · 14 Mars 2024

Pour terminer voici une solution avec l'objet Find :

VB:

Sub Coller_dans_Word()
Dim Wapp As Object, texte$, Wdoc As Object, tbl As Object
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
On Error GoTo 0
If Wapp Is Nothing Then MsgBox "Ouvrez le document Word": Exit Sub
texte = "Silicium et nostradae cubitus."
Set Wdoc = Wapp.ActiveDocument
Wdoc.Content.Select
With Wapp.Selection.Find
    .ClearFormatting
    If Not .Execute(FindText:=texte) Then MsgBox "Texte non trouvé !": Exit Sub
End With
For Each tbl In Wdoc.Tables
    If tbl.Range.Start > Wapp.Selection.Start Then
        tbl.Select
        tbl.Delete
        [Tableau5].ListObject.Range.Copy 'copie le tableau structuré
        Wapp.Selection.Paste 'coller
        Application.CutCopyMode = 0
        Exit For
    End If
Next tbl
Wdoc.Range(0, 0).Select
AppActivate Wapp.Caption, True 'facultatif, active Word
Wdoc.ActiveWindow.WindowState = 1 'wdWindowStateMaximize
End Sub

XL 2021 Transfert tableau structuré EXCEL à un endroit précis de WORD

BARNS

XLDnaute Junior

Pièces jointes

job75

XLDnaute Barbatruc

BARNS

XLDnaute Junior

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires