Hi guys, I'm trying to create a macro in Word 2019 that will help split a long document into multiple shorter documents. Here's a summary of what I'm trying to make the macro do:



  1. Receive input on what heading to use as base.
  2. Search for that heading from the beginning of the document.
  3. Once found an instance of that heading, proceed to copy everything from that heading downward, until it hit another instance of the same heading.
  4. Create a new document and make a duplication of the copied content over there.
  5. Save the file in a specified path, and append a number at the end to denote its position in the original document.
  6. Close the new file and go back to the original document.
  7. Loop the above till the end of the original document.



After Googling around, I've manage to cobbled together a piece of code as follow:


Sub SplitChapterByHeading()
    Application.ScreenUpdating = False
    On Error GoTo ErrorReport
    ' Cancel macro when no heading is defined
    Dim HeadingName As Integer
    ' The name of the heading to use as base
    Dim Msg As String
    ' This is what to display on the dialog box
    Dim TotalLines      As Long
    Dim x               As Long
    Dim Groups()        As Long
    Dim Counter         As Long
    Dim y               As Long
    Dim FilePath        As String
    Dim FileName()      As String
     
    PlayTheSound "W21 - Awaiting Orders.wav"
    Msg = "Which Heading to use as base (NUMBER ONLY)?"
    HeadingName = InputBox(Msg)
    Application.DisplayAlerts = False
    PlayTheSound "W22 - As You Requested.wav"
     
    FilePath = ActiveDocument.Path
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
    Do
        TotalLines = Selection.Range.Information(wdFirstCharacterLineNumber)
        Selection.MoveDown Unit:=wdLine, Count:=1
    Loop While TotalLines <> Selection.Range.Information(wdFirstCharacterLineNumber)
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
    For x = 1 To TotalLines
        If Selection.Style = "Heading " & HeadingName Then
            Counter = Counter + 1
            ReDim Preserve Groups(1 To Counter)
            ReDim Preserve FileName(1 To Counter)
            Groups(Counter) = x
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            FileName(Counter) = Selection.Text
            FileName(Counter) = Left(Selection.Text, Len(FileName(Counter)) - 1)
            Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
        End If
        Selection.MoveDown Unit:=wdLine, Count:=1
    Next
    Counter = Counter + 1
    ReDim Preserve Groups(1 To Counter)
    Groups(Counter) = TotalLines
     
    For x = 1 To UBound(Groups) - 1
        y = Groups(x + 1) - Groups(x)
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=Groups(x)
        Selection.MoveDown Unit:=wdLine, Count:=y, Extend:=wdExtend
        Selection.Copy
        Documents.Add
        Selection.Paste
        ActiveDocument.SaveAs FilePath & "\Splited Document\" & FileName(x) & ".docx"
        ActiveDocument.Close
    Next x
     
ErrorReport:


End Sub

When I do a test run on a document, it correctly find the first heading, but didn't move downward to copy the content underneath it. It only copy a small portion of the heading, and put it in a new document that it doesn't even bother to save, then end.


I could only hazard a guess that a potential source of error is because the heading in my test document contained a line break. For example, here's how a heading looks like:


Chapter 1
The Beginning
After removing the line break, the macro did manage to get further down, but it still didn't copy the whole section, and didn't save the file.


Since my knowledge of VBA is extremely rudimentary, I have no idea how to fix it.


Could someone help me out with this?

Note: here's the test file I use, just in case it contains some sort of peculiarity: [WIP] Split test.docx