Merci pour votre aide, j'ai reussi à faire ce que je souhaitait !


Pour les curieux et ceux que ça pourrait interresser voici le code :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub Extract()
Dim celDeb As String, celFin As String
Dim aWord As Object    'Late binding
Dim nbSauts As Integer, i As Integer
 
With Worksheets("Matrice rapport") '"Matrice rapport" est le nom de la feuille de travail
    nbSauts = .HPageBreaks.Count    'la variable prend le nombre de sauts de page dans la feuille
    If nbSauts > 1 Then             ' on vérifie qu'il y a bien plus 1 saut de apge
        Set aWord = CreateObject("Word.Application")
        With aWord
            .Documents.Open "C:\Users\TFT\Théo FEUILLET\Rapport_Type.docx" 'on ouvre le document "Rapport_Type.docx" à l'addresse "C:\.....
            .Visible = False
        End With
 
            .Range("H54").Copy  'la cellule contenant la date
            With aWord.Selection
                .Goto What:=-1, Name:="date" 'on se place au signet "date"
                .PasteSpecial , Link:=False, DataType:=10, DisplayAsIcon:=False 'puis on colle au format 10 texte "brut"
            End With
 
        For i = 1 To nbSauts - 1 'boucle pour copier et collé toutes les pages
            celDeb = .HPageBreaks(i).Location.Address               'on récupère la cellule suivant du saut de page 1
            celFin = .HPageBreaks(i + 1).Location.Offset(-1, 9).Address    'on récupère la cellule précédante et décallée de 10 colonnes du saut de page
            .Range(celDeb & ":" & celFin).Copy  'on copie touts entre les 2 cellules
            With aWord.Selection
                .Goto What:=-1, Name:="ici" & i  ' on va au signet "iciX" avec X = i
                .PasteSpecial , Link:=False, DataType:=9, DisplayAsIcon:=False ' on colle au format 9 image
            End With
            Application.CutCopyMode = False
        Next i
 
        aWord.Quit SaveChanges:=True
        Set aWord = Nothing
    End If
End With
MsgBox "Extraction réalisée dans Rapport Type"
End Sub