Option Explicit
 
Sub DecoupageDoc()
Dim NomDocDepart As String
Dim i As Long, j As Long
Dim Termine As Boolean
Dim NumeroDoc As String, PgDepart As Long
Dim Dossier As String, DossierSauvegarde As String
Dim NbPages As Long
Const DecouperEn As Integer = 10
 
    Application.ScreenUpdating = False
 
    NomDocDepart = ActiveDocument.Name
    NbPages = ActiveDocument.Content.ComputeStatistics(wdStatisticPages)
 
    Dossier = ActiveDocument.Path
    DossierSauvegarde = Dossier & "\" & "Charcuterie"
    VerifDossier DossierSauvegarde
 
    Selection.EndKey Unit:=wdStory
    Selection.HomeKey Unit:=wdStory
 
    i = 0
    Termine = False
 
    ChangeFileOpenDirectory DossierSauvegarde
 
    Do While True
        i = i + 1
 
        NumeroDoc = Trim(Str(i))
        Do While Len(NumeroDoc) < 4
            NumeroDoc = "0" + NumeroDoc
        Loop
 
        PgDepart = Selection.Range.Start
        For j = 1 To DecouperEn
            Application.Browser.Next
        Next
 
        If Selection.Range.Start = PgDepart Then
            Termine = True
            Selection.EndKey Unit:=wdStory
        Else
            Selection.MoveLeft Unit:=wdCharacter, Count:=1
        End If
 
        ActiveDocument.Range(Start:=PgDepart, End:=Selection.Range.Start).Copy
        Documents.Add Template:="Normal", NewTemplate:=False
        Selection.Paste
 
        ActiveDocument.SaveAs FileName:=Left(NomDocDepart, Len(NomDocDepart) - 4) + _
                                        "_" + NumeroDoc + ".doc", FileFormat:=wdFormatDocument
        ActiveDocument.Close
 
        Documents(NomDocDepart).Activate
        If Termine Then Exit Do
 
        Selection.MoveRight Unit:=wdCharacter, Count:=1
    Loop
    Application.ScreenUpdating = True
End Sub
 
Private 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