Option Explicit
 
Sub DecoupagePageParPage()
Dim NomDocDepart As String
Dim i As Long
Dim Dossier As String, DossierSauvegarde As String
Dim NumDoc As Long, NbPages As Long
 
    NomDocDepart = ActiveDocument.Name
    Dossier = ActiveDocument.Path
    DossierSauvegarde = Dossier & Application.PathSeparator & "Charcuterie"
    VerifDossier (DossierSauvegarde)
     
    Application.ScreenUpdating = False
    Application.Browser.Target = wdBrowsePage
    NbPages = ActiveDocument.Content.ComputeStatistics(wdStatisticPages)
     
    ChangeFileOpenDirectory DossierSauvegarde
 
    For i = 1 To NbPages
       
      ActiveDocument.Bookmarks("\page" ).Range.Copy
      Documents.Add
      Selection.Paste
       
      NumDoc = NumDoc + 1
       
      ActiveDocument.SaveAs FileName:=Left(NomDocDepart, Len(NomDocDepart) - 4) + _
            "_" + CStr(NumDoc) + ".doc", FileFormat:=wdFormatDocument
      ActiveDocument.Close
 
      Application.Browser.Next
    Next i
     
    Application.ScreenUpdating = True
End Sub
 
Sub VerifDossier(ByVal DossierSauvegarde As String)
On Error GoTo erreur
    ChDir DossierSauvegarde
    Exit Sub
erreur:
    If Err.Number = 76 Then
        MkDir (DossierSauvegarde)
        Resume Next
    End If
End Sub