Word VBA Excel-Word: Coller du texte l'un en dessous de l'autre

Conrad13

XLDnaute Nouveau
Bonjour,

Je souhaite construire à partir d'un document source plusieurs contrats en y insérant les bon chapîtres. J'ai un document word dans lequel j'ai listés les chapitres sous forme d'un tableau. Il s'agit de données publipostées. La première colonne représente la ligne du tableau la seconde colonne le libellé et la troisième le texte publiposté
1615462832884.png


Je souhaite utiliser un classeur Excel dans lequel j'indiquerai le Nom du contrat puis les colonnes suivants représenteraient les chapîtres qui correspondent au contrat. J'ai donc crée le classeur sous cette forme:
1615463097624.png


Dans l'onglet Feuil1, j'ai les chapitres tels qu'indiqué dans le document Word en colonne A et en colonne B le numéro de chapitre qui correspond à la ligne du tableau qui se trouve dans le document Word.

1615464308854.png


Je ne suis pas expert en macro mais je me débrouille un peu. J'ai déjà crée la macro suivante:

Sub NouveauDoc()
Dim r As Long
Dim s As Long
Dim Chapitre As String
Dim NumChapitre As Long
Dim Name As String
Dim WordApp As Object
Dim WordDoc As Object

r = 2

'A FAIRE:Créer un folder nom= "Contrat + Nom Client + Date du jour" Nom client à mettre quelque part dans la Feuil1

'Lancer la boucle tant que la colonne de contrat (A) est vide (Feuil1)

Do While Feuil2.Cells(r, 1) <> ""

'Trouver le nom pour le nouveau document word
Name = Feuil2.Cells(r, 1).Value

'Créer un nouveau document Word
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add

'Nommer le nouveau document
WordApp.ActiveDocument.SaveAs Filename:=Name & ".doc", FileFormat:=wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False

'A FAIRE: Insérer Entête et Pieds de page

'Tant que A:A est <> vide sur chapitre=ce qui se trouve dans la colonne r,s

For s = 2 To 65

'Si les chapitres existent identifier les chapîtres
If Feuil2.Cells(r, s) <> "" Then
Chapitre = Feuil2.Cells(r, s)

'Rechercher le numéro du chapitre dans l'onglet Feuil1 dans A:B
NumChapitre = WorksheetFunction.VLookup(Chapitre, Feuil1.Range("A:B"), 2, False)

'Ouvrir le document Word TEST
GetObject(, "Word.Application").Documents("TEST.docx").Activate

'Sélectionner et Copier la céllule correspondante au numéro de chapitre qui corresponds à l'indice dans la cellule 3
GetObject(, "Word.Application").Documents("TEST.docx").Tables(1).Rows(NumChapitre).Cells(3).Range.Select
Selection.Copy

'Coller la ligne (NumChapter) qui corresponds à l'indice dans la cellule 3 dans le document
'BLOCAGE ICI:
'WordDoc.Content.InsertAfter

'Selection.Paste

'WordDoc.Content.Collapse Direction:=wdCollapseEnd
'Selection.EndKey Unit:=wdStory
'Selection.EndOf Unit:=wdStory, Extend:=wdMove
'Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
'Selection.Range(Start:=0, _
End:=WordDoc.End).Content.Select.EndKey Unit:=wdStory, Extend:=wdMove
'GetObject(, "Word.Application").Documents(Name & ".doc").Select
'Selection.Range

WordDoc.Content.Start


'Coller les information copiées
WordDoc.Content.PasteAndFormat (wdSingleCellText)


'A FAIRE: Fermer le document Word
End If
Next

r = r + 1

Loop

End Sub

Seulement je bloque. Quand je ne mets pas la ligne "WordDoc.Content.Start", le nouveau document Word s'ouvre, se nomme correctement et me colle les bons chapitres mais en écrasant le chapitre précédant. Donc au final, je me retrouve avec autant de Contrat que nécéssaire mais seulement avec le dernier chapître dans chacun d'eux... Alors que ce que je souhaiterais, c'est que chaque chapîtres se place en dessous du dernier... Quand je tente d'appliquer ce que j'ai vu sur des forums ici et là, j'ai une erreur sur la macro comme quoi "Propriété ou méthode non gérée pour cet Objet". J'ai ce message sur tous les champs en rouge. Je pense que je loupe quelque chose mais je ne sais pas quoi...

Je vous partage mes deux documents:

-Le classeur Excel "Publipostage_Base" qui contient la macro "NouveauDoc" dans le module 1
-Le document word TEST qui sert de base à la création de contrat.

J'espère que vous allez pouvoir m'aider.

D'avance merci
 

Pièces jointes

  • Publipostage_Base.xlsm
    36.3 KB · Affichages: 8
Dernière édition:

Conrad13

XLDnaute Nouveau
J'ai finalement trouvé la solution. Si ça peux intéresser mon code (il n'est pas propre) est devenu:

Sub NouveauDoc()
Dim r As Long
Dim s As Long
Dim Chapitre As String
Dim NumChapitre As Long
Dim Name As String
Dim WordApp As Word.Application
Dim WordDoc As Object
Dim path As String
Dim Entete As String

r = 2
path = ObtenirCheminBureau()



'Créer un fichier nom= "Contrat + Nom Client + Date du jour"
If Dir(path & "/" & Feuil1.Range("F2").Value & Date, vbDirectory) = "" Then
MkDir path:=path & "\" & "Contrats - " & Feuil1.Range("F2").Value & " - " & Feuil1.Range("F4").Value 'create folder if not available
End If

'Lancer la boucle tant que la colonne de contrat (A) est vide (Feuil1)
Do While Feuil2.Cells(r, 1) <> ""

'Trouver le nom pour le nouveau document word
Name = Feuil2.Cells(r, 1).Value

'Chercher l'entête
GetObject(, "Word.Application").Documents("TEST.docx").Activate

With GetObject(, "Word.Application").Documents("TEST.docx").Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Copy
End With


'Créer un nouveau document Word
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add

'Nommer le nouveau document
WordApp.ActiveDocument.SaveAs Filename:=path & "\" & "Contrats - " & Feuil1.Range("F2").Value & " - " & Feuil1.Range("F4").Value & "/" & Name & ".doc", FileFormat:=wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False

'Insérer Entête

WordDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Paste

'Chercher le footer
With GetObject(, "Word.Application").Documents("TEST.docx").Sections(1)
.Footers(wdHeaderFooterPrimary).Range.Copy
End With

'Insérer le footer

WordDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range.Paste

'Tant que A:A est <> vide sur chapitre=ce qui se trouve dans la colonne r,s
For s = 2 To 65

'Si les chapitres existent identifier les chapîtres
If Feuil2.Cells(r, s) <> "" Then
Chapitre = Feuil2.Cells(r, s)

'Rechercher le numéro du chapitre dans l'onglet Feuil1 dans A:B
NumChapitre = WorksheetFunction.VLookup(Chapitre, Feuil1.Range("A:B"), 2, False)

'Activer le document Word TEST
GetObject(, "Word.Application").Documents("TEST.docx").Activate

'Sélectionner et Copier la céllule correspondante au numéro de chapitre qui corresponds à l'indice dans la cellule 3
GetObject(, "Word.Application").Documents("TEST.docx").Tables(1).Rows(NumChapitre).Cells(3).Range.Copy

'Coller la ligne (Numhapter) qui corresponds à l'indice dans la cellule 3 dans le document
WordDoc.Application.Selection.WholeStory
WordApp.Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
WordDoc.Application.Selection.MoveDown Unit:=wdLine, Count:=2
WordApp.Selection.TypeParagraph
WordDoc.Application.Selection.PasteAndFormat (wdSingleCellText)


End If
Next

'Sauvegarder le document crée
WordDoc.Save

'Fermer le document Word
WordDoc.Application.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
r = r + 1

Loop

End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 900
Membres
101 834
dernier inscrit
Jeremy06510