Sub SortiereKapitelAZ() 
Dim doc As Document, kapitel As Document 
Dim titl As String, inhalt As String 
Dim ranf As Long, tanf As Long, rende As Long 
Dim seiten As Long, pfad As String 
Dim fso As FileSystemObject 
 
Set doc = ActiveDocument 
seiten = doc.ComputeStatistics(wdStatisticPages) 
pfad = doc.Path & "\kapitel" 
Set fso = New FileSystemObject 
If Not fso.FolderExists(pfad) Then 
    fso.CreateFolder pfad 
End If 
 
'Schritt 1: Alle Kapitel aus Dokument ausschneiden und als separate Datei speichern 
With Selection 
    .HomeKey unit:=wdStory 
     
    ranf = .Start 
    With .Find 
        .ClearFormatting 
        .Text = "*\:" 
        .MatchWildcards = True 
        .Execute 
    End With 
     
    For i = 1 To seiten - 1 
        titel = .Text 
        titel = Replace(titel, ":", "") 
        .Collapse wdCollapseEnd 
        tanf = .Start 
         
        With .Find 
            .Text = "^m" 
            .MatchWildcards = False 
            .Execute 
        End With 
         
        rende = .End 
        .Collapse wdCollapseStart 
        .End = .Start 
        .Start = tanf 
        inhalt = .Text 
        .Start = ranf 
        .End = rende 
        .Cut 
        .Expand unit:=wdLine 
        .Delete 
        Set kapitel = Documents.Add 
        kapitel.Range.Text = titel & ":" & inhalt 
        kapitel.SaveAs pfad & "\" & titel & ".doc", wdFormatDocument 
        kapitel.Close 
        doc.Activate 
         
        ranf = .Start 
        With .Find 
            .ClearFormatting 
            .Text = "*\:" 
            .MatchWildcards = True 
            .Execute 
        End With 
    Next i 
     
    'Letzte Seite: 
    With .Find 
        .ClearFormatting 
        .Text = "*\:" 
        .MatchWildcards = True 
        .Execute 
    End With 
    titel = .Text 
    titel = Replace(titel, ":", "") 
    .Collapse wdCollapseEnd 
    .End = doc.Range.End 
    inhalt = .Text 
    .Start = doc.Range.Start 
    .Cut 
    Set kapitel = Documents.Add 
    kapitel.Range.Text = titel & ":" & inhalt 
    kapitel.SaveAs pfad & "\" & titel & ".doc", wdFormatDocument 
    kapitel.Close 
    doc.Activate 
    ranf = .Start 
     
'Neu rein verknüpfen 
    With Application.FileSearch 
        .LookIn = pfad 
        .FileName = "*.doc" 
        .Execute msoSortByFileName, msoSortOrderAscending 
    End With 
 
    For i = 1 To Application.FileSearch.FoundFiles.Count - 1 
        .Fields.Add .Range, wdFieldIncludeText, Chr(34) & Replace(Application.FileSearch.FoundFiles(i) & Chr(34), "\", "\\") 
        .Collapse wdCollapseEnd 
        .InsertBreak wdPageBreak 
        ranf = .End + 1 
    Next i 
    'Letzte Seite: 
    .Fields.Add .Range, wdFieldIncludeText, Chr(34) & Replace(Application.FileSearch.FoundFiles(i) & Chr(34), "\", "\\") 
     
End With 
 
MsgBox "Fertig!" 
 
End Sub