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