Sub ChapterChopper()
' Paul Beverley - Version 20.10.23
' Chops a book file into separate chapter files

' On a Mac, you will need something like:
myFolder = "/Users/Paul/My Documents/My book folder/"

' On Windows, you will need something like:
myFolder = "C:\Documents and Settings\Paul\My book folder\"

myFind = "[^13^12][0-9][0-9] "
myMoveStart = 1
myFontSize = 22
myFirstFilename = "00"
myChapterPrefix = "Chapter "
' myChapterPrefix = ""

myResponse = MsgBox("Have you created a ""aaBlank"" file?", _
     vbQuestion + vbYesNo, "ChapterChopper")
If myResponse <> vbYes Then Exit Sub

Set myChapter = ActiveDocument.Content
Set rngSource = ActiveDocument.Content
theVeryEnd = rngSource.End
With rngSource.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = myFind
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .MatchWholeWord = False
  .Execute
End With

doContinue = False
myNextFilename = myFirstFilename
myCount = 0
Do While rngSource.Find.Found = True
  If myMoveStart > 0 Then rngSource.Start = rngSource.Start + myMoveStart
  myChapter.End = rngSource.Start
  If doContinue = True Then rngSource.Select
  If rngSource.Font.Size = myFontSize Then
    myCount = myCount + 1
    myFileName = myNextFilename
    myNextFilename = Trim(rngSource.Text)
    myChapter.End = rngSource.Start
    Documents.Open fileName:=myFolder & "aaBlank.docx"
    Set rng = ActiveDocument.Content
    rng.FormattedText = myChapter.FormattedText
    If doContinue = False Then
      myResponse = MsgBox("Save " & myChapterPrefix & _
           myFileName & " and continue?", _
       vbQuestion + vbYesNo, "ChapterChopper")
      If myResponse <> vbYes Then Exit Sub
      doContinue = True
    End If
    ActiveDocument.SaveAs fileName:=myFolder & myChapterPrefix & myFileName
    Debug.Print myFileName
    DoEvents
    ActiveDocument.Close SaveChanges:=False
    myChapter.Collapse wdCollapseEnd
  End If
  rngSource.Collapse wdCollapseEnd
  rngSource.Find.Execute
  DoEvents
Loop

myFileName = myNextFilename
myChapter.End = theVeryEnd
Documents.Open fileName:=myFolder & "aaBlank.docx"
Set rng = ActiveDocument.Content
rng.FormattedText = myChapter.FormattedText
ActiveDocument.SaveAs fileName:=myFolder & myChapterPrefix & myFileName
ActiveDocument.Close SaveChanges:=False
MsgBox "Files created: " & myCount + 1
End Sub