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

[BARNS]

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]

Bonjour BARNS,

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]

Oupsy, je viens de MAJ le fichier.

 

[job75]

Bonjour BARNS, le forum,

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

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]

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

 

[job75]

Bon il faut ajouter True :

AppActivate Wapp.Caption, True 'facultatif,active Word

 

[job75]

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

 

[job75]

Bonjour le forum,

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

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

A+

 

[job75]

Pour terminer voici une solution avec l'objet Find :

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