Option Explicit Sub RecopieRef() ' Liste des noms des documents à renseigner Dim NomsCible As Variant ' ++++ à compléter NomsCible = Array("d:\Temp\test1.docx", "d:\Temp\test2.docx", "d:\Temp\test3.docx") ' plusieurs documents cibles Dim nb As Long nb = UBound(NomsCible) + 1 ' Liste des signets du documents source ' le texte à recopier est encadré par deux signets sucessifs, il en faut donc un de plus ' on suppose que la dernière borne est la fin du document Dim NomsSignetsSource As Variant ' ++++ à compléter ' une paire de signet délimite la zone à prendre pour le premier document ' la paire suivante délimite la zone à prendre pour le premier document ' etc. ici le troisième montre comment prendre depuis un signet jusqu'à la fin du document NomsSignetsSource = Array("Signet1d", "Signet1f", _ "Signet2d", "Signet2f", _ "Signet3d", "\EndOfDoc") '(indicei) ' Pour les document cible, il y a une seule paire de signets pour chaque document (indice j) Dim NomsSignetsCible As Variant ' +++ à compléter NomsSignetsCible = Array("Signet1d", "Signet1f", _ "Signet2d", "Signet2f", _ "Signet3d", "Signet3f") Dim DocSource As Document Dim DocCourant As Document Dim i As Long Dim j As Long Dim erreur As Boolean Dim z1 As Range Dim z1d As Long Dim z1f As Long Dim z2 As Range Dim z2d As Long Dim z2f As Long Dim signetSd As Bookmark ' signet de début de texte à copier Dim signetSf As Bookmark ' signet de fin de texte à copier Dim signetDd As Bookmark ' signet de début de où copier Dim signetDf As Bookmark ' signet de fin où copier ' Au départ le document source est seul ouvert Set DocSource = ActiveDocument ' boucle sur le nb de cas j = 0 For i = 0 To 2 * nb - 1 Step 2 On Error GoTo erreurFichier Set DocCourant = Documents.Open(NomsCible(i)) On Error GoTo 0 ' vérifier que les signets existent dans le doc source erreur = False If DocSource.Bookmarks.Exists(NomsSignetsSource(i)) = False Then erreur = True MsgBox "Signet '" & NomsSignetsSource(i) & "' non trouvé dans document source", vbOKOnly + vbCritical, "Erreur signet" End If If DocSource.Bookmarks.Exists(NomsSignetsSource(i + 1)) = False Then erreur = True MsgBox "Signet '" & NomsSignetsSource(i + 1) & "' non trouvé dans document source", vbOKOnly + vbCritical, "Erreur signet" End If If erreur = True Then MsgBox "Abandon du travail en raison de signet(s) absent(s) dans le document à recopier", vbOKOnly + vbCritical, "Erreur signet" End End If ' vérifier que les signets existent dans le doc destinataire If DocCourant.Bookmarks.Exists(NomsSignetsCible(j)) = False Then erreur = True MsgBox "Signet '" & NomsSignetsCible(j) & "' non trouvé dans document cible", vbOKOnly + vbCritical, "Erreur signet" End If If DocCourant.Bookmarks.Exists(NomsSignetsCible(j + 1)) = False Then erreur = True MsgBox "Signet '" & NomsSignetsCible(j + 1) & "' non trouvé dans document cible", vbOKOnly + vbCritical, "Erreur signet" End If If erreur = True Then MsgBox "Abandon du travail en raison de signet(s) absent(s) dans le document où recopier", vbOKOnly + vbCritical, "Erreur signet" End End If ' définition de la zone à copier ' début (à ajuster selon la définition des signets) : ' ++++ à ajuster z1d = DocSource.Bookmarks(NomsSignetsSource(i)).Range.End + 1 ' fin If NomsSignetsSource(i + 1) = "\EndOfDoc" Then z1f = DocSource.Bookmarks(NomsSignetsSource(i + 1)).Range.Start Else ' ++++ à ajuster z1f = DocSource.Bookmarks(NomsSignetsSource(i + 1)).Range.Start - 1 End If '' vérifier que z1f > z1d ' ++++ à programmer Set z1 = DocSource.Range(Start:=z1d, End:=z1f) ' définition de la zone où copier ' début : ' ++++ à ajuster z2d = DocCourant.Bookmarks(NomsSignetsCible(j)).Range.End + 1 ' fin If NomsSignetsCible(j + 1) = "\EndOfDoc" Then z2f = DocCourant.Bookmarks(NomsSignetsCible(j + 1)).Range.Start Else ' ++++ à ajuster z2f = DocCourant.Bookmarks(NomsSignetsCible(j + 1)).Range.Start - 1 End If '' vérifier que z2f > z2d ' ++++ à programmer Set z2 = DocCourant.Range(Start:=z2d, End:=z2f) ' remplacement du texte z2.Text = z1.Text ' sauver et enregistrer le document obtenu ? ' pour l'instant en commentaire pour garder la main sur la sauvegarde. 'DocCourant.Save DocCourant.Close j = j + 2 GoTo suiteI erreurFichier: MsgBox "Fichier " & NomsCible(i) & " non trouvé", vbOKOnly + vbCritical, "Fichier incorrect" Resume suiteI suiteI: Next i MsgBox "Terminé" End Sub