@Gast763 super vielen Dank! Damit bin ich schonmal ein Schritt weiter. Aber wüsstest du wie man das Makro so umschreibt, dass man nciht mehr jede einzelne Seite sondern, die Seiten aufspaltet. Heißt ich möchte folgende Dokumente haben:

Seite 2

Seite 3-5

Seite 6-10

Seite 10-14

Seite 14-20

Seite 20-25

wie müsste den folgenden Makro umschreiben?

Sub JedeSeiteEinNeuesDokumentMitKopfUndFusszeilen()
Dim oDoc As Document, nDoc As Document, oRange As Range
Dim cDateiname As String
Set oDoc = ActiveDocument
Max = oDoc.ComputeStatistics(wdStatisticPages)
For i = 1 To Max
oDoc.Activate
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
A = Selection.Information(wdActiveEndSectionNumber)
Set oRange = Selection.Bookmarks("\Page").Range
If Right(oRange.Text, 1) = Chr(12) Then
oRange.SetRange Start:=oRange.Start, End:=oRange.End - 1
End If
Set nDoc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName)
nDoc.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = False
nDoc.Content.FormattedText = oRange.FormattedText
s = nDoc.ComputeStatistics(wdStatisticPages)
'Wenn eine 2. Seite mit einem einzigen leeren Absatz entstanden ist
If s = 2 And nDoc.Paragraphs.Last.Range.Text = Chr(13) Then
nDoc.Paragraphs.Last.Range.Delete
End If
Set oRange = oDoc.Sections(A).Headers(1).Range.FormattedText
If Len(oRange.Text) > 1 Then
oRange.SetRange Start:=oRange.Start, End:=oRange.End - 1
nDoc.Sections(1).Headers(1).Range.FormattedText = oRange.FormattedText
End If
Set oRange = oDoc.Sections(A).Footers(1).Range.FormattedText
If Len(oRange.Text) > 1 Then
oRange.SetRange Start:=oRange.Start, End:=oRange.End - 1
nDoc.Sections(1).Footers(1).Range.FormattedText = oRange.FormattedText
End If

nDoc.Activate
If Zeile > 1 Then
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=0
End If
If Selection.Bookmarks.Exists("\Line") Then
cDateiname = RTrim(Selection.Bookmarks("\Line").Range.Text)
Selection.Bookmarks("\Line").Range.Cut
Else
cDateiname = RTrim("D" & Format(i, "000"))
End If
cDateiname = Left(cDateiname, Len(cDateiname) - 1) & ".doc"
nDoc.SaveAs FileName:=Praefix & cDateiname, AddToRecentFiles:=False
nDoc.Close
Next i
End Sub