Modification de docs Word à partir d'un liste sur Excel
Bonjour à tous,
Je cherche à faire une macro qui à partir d'un classeur excel va ajouter une phrase à chaque fichier word d'un dossier particulier et dont le nom apparaît dans le excel en question.
La phrase serait à ajouter toujours au même endroit dans les documents qui sont tous écrits de la même manière. Par exemple après la mention : "durée du contrat :"
Bien sûr, si le document présent dans le dossier n'est pas dans le tableau, il n'est pas modifié.
Je suis preneur de vos idées et suggestions.
Merci beaucoup
Bonjour,
C'est simple, s'il y a des signets aux bons endroits :
WordDoc.Bookmarks("MonSignet").Range.Text = MaDonneeExcelPierre
Bonjour,
Merci pierrep56 pour ta proposition. Dans mon cas, ça va être moins simple, il n'y a pas de signet. Les documents sont déjà créés et ne comporte pas de signet. J'en ai plus de 400.
En fait, j'ai presque envie de dire que je sais gérer la modification des documents Word (ouverture 1 par 1, trouver l'endroit où ajouter le texte, ajouter le texte). Tout ça je sais le faire depuis une VBA Word. Mon problème c'est surtout faire le lien entre le document Word et le tableur Excel comportant les noms des documents.
Un peu du style :
If ActiveDocument.Name Like ... ThenOù le Like permettrait d'aller chercher dans le Excel en question.
La nuit a passé et m'a permis d'être plus au clair sur ce dont j'ai besoin. J'espère que mon message est plus clair. N'hésitez pas à me demander de préciser si besoin
Bonjour x--ben,
Merci de nous donner le code complet de votre VBA Word SVP,
pour moi, il suffit de le transposer dans votre classeur Excel
Il serait bien aussi que nous puissions avoir un Fichier Excel avec la même structure que l'actuel
@+
Bonjour,
Voici mon code VBA Word que j'ai bricolé :
Sub DureeContrat()
Dim xFd As FileDialog 'déclare la variable comme un objet
Dim xFdItem As Variant
Dim xFileName As String
Dim xlApp As Excel.Application
Dim xlDoc As Excel.Workbook
Dim chemin_fichier As String
Dim Table()
'Dim ws As Worksheet
chemin_fichier = "\\XXXXX$\Operationnel\10_MesuresAgroEnvirClim\07_Notices\2021\Notices_a_mettre_a_jour\DureeEngagement.xlsx"
Application.ScreenUpdating = False
Set xlApp = CreateObject("Excel.Application")
With Workbooks.Open(chemin_fichier)
ws = .Sheets(1) 'pour chacune de ses feuilles
Table = ws.Range("A2:D705")
End With
Set xFd = Application.FileDialog(msoFileDialogFolderPicker) 'créer l'objet comme une fenêtre de dialogue s'ouvre pour sélectionner un dossier
If xFd.Show = -1 Then 'ouvre la fenêtre de dialogue au niveau du dernier dossier sélectionné pour que l'utilisateur sélectionne
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator 'chemins des fichiers contenus dans le dossier sélectionné
xFileName = Dir(xFdItem & "*.docx*") 'variable prend la valeur des noms de fichiers
Do While xFileName <> "" 'boucle tant que la variable n'est pas vide
With Documents.Open(xFdItem & xFileName)
' Macro1 Macro
If ActiveDocument.TrackRevisions = True Then
ActiveDocument.Unprotect Password:="asp"
ActiveDocument.TrackRevisions = False
End If
If ActiveDocument.Name Like Table(j, 2) Then
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "annuellement pendant la durée de l'engagement."
.Replacement.Text = "annuellement pendant la durée de l'engagement.^p" & Table(4) 'remplace l'ancien 2021 par ce qui est entre guillemets. "" pour effacer ; ^p pour revenir à la ligne
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Workbooks.Close
End If
ActiveDocument.Save
Application.DisplayAlerts = wdAlertsNone
ActiveDocument.Close
Application.DisplayAlerts = wdAlertsAll
End With
xFileName = Dir
Loop
End If
Application.ScreenUpdating = True
MsgBox ("Les changements sont terminés.")
End SubJ'ai un problème à ce niveau :
With Workbooks.Open(chemin_fichier)
ws = .Sheets(1) 'pour chacune de ses feuilles
Table = ws.Range("A2:D705")
End WithOù je n'arrive pas à choisir la feuille du document ...
Le tableur en question est joint.
Merci pour votre aide !
Bonjour x--ben,
Question : pourquoi ne pas avoir fait l'inverse, partir d'un classeur Excel avec le code qui ouvre et modifie les doc Word ?
@+
Parce que j'avais la chose prête depuis Word. Mais je peux essayer oui
Mais je pense que j'étais pas trop loin, c'est dommage
Réussi depuis Excel, voici le code !
Merci pour vos pistes
Sub DureeContrat()
Dim xFd As FileDialog 'déclare la variable comme un objet
Dim xFdItem As Variant
Dim xFileName As String
Dim WdApp As Word.Application
Dim WdDoc As Word.Document
Dim chemin_fichier As String
Dim Table()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Feuil1") 'abreviation ws = la feuille du classeur indiquée
Table = ws.Range("A2:D705")
Set WdApp = CreateObject("Word.Application")
Set xFd = Application.FileDialog(msoFileDialogFolderPicker) 'créer l'objet comme une fenêtre de dialogue s'ouvre pour sélectionner un dossier
If xFd.Show = -1 Then 'ouvre la fenêtre de dialogue au niveau du dernier dossier sélectionné pour que l'utilisateur sélectionne
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator 'chemins des fichiers contenus dans le dossier sélectionné
xFileName = Dir(xFdItem & "*.docx*") 'variable prend la valeur des noms de fichiers
Do While xFileName <> "" 'boucle tant que la variable n'est pas vide
With Documents.Open(xFdItem & xFileName)
' Macro1 Macro
For j = LBound(Table, 1) To UBound(Table, 1)
If ActiveDocument.TrackRevisions = True Then
ActiveDocument.Unprotect Password:="asp"
ActiveDocument.TrackRevisions = False
End If
If ActiveDocument.Name Like Table(j, 2) Then
Set WdDoc = ActiveDocument
With WdDoc.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
'With Range.Find
.Text = "annuellement pendant la durée de l'engagement."
.Replacement.Text = "annuellement pendant la durée de l'engagement.^p^p" & Table(j, 4) 'remplace l'ancien 2021 par ce qui est entre guillemets. "" pour effacer ; ^p pour revenir à la ligne
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
ActiveDocument.Save
Application.DisplayAlerts = wdAlertsNone
ActiveDocument.Close
Application.DisplayAlerts = wdAlertsAll
End If
Next
End With
xFileName = Dir
Loop
End If
Application.ScreenUpdating = True
MsgBox ("Les changements sont terminés.")
End Sub