How to make a macro that split word documents, using headings as markers?

[longnguyen94]

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:




Receive input on what heading to use as base.
Search for that heading from the beginning of the document.
Once found an instance of that heading, proceed to copy everything from that heading downward, until it hit another instance of the same heading.
Create a new document and make a duplication of the copied content over there.
Save the file in a specified path, and append a number at the end to denote its position in the original document.
Close the new file and go back to the original document.
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: 30419

[longnguyen94]

UPDATE: After an afternoon of Googling, I've managed to cobble out a new code that works significantly better! It's as below:


Sub SplitChapterByHeading()


Application.ScreenUpdating = False
Dim Rng As Range
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 FilePath As String
FilePath = ActiveDocument.Path


'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"


With ActiveDocument.Range
Do
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = "Heading " & HeadingName
.Format = True
.Forward = True
.MatchCase = True
.Wrap = wdFindStop
.MatchWildcards = False
.Execute
End With

If .Find.Found = True Then
Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Rng.Select
Selection.Copy
Documents.Add
Selection.Paste
ActiveDocument.SaveAs FileName:=FilePath & "\Splited Document\chap.docx"
ActiveDocument.Close
End If
Loop While .Find.Found
End With
Application.ScreenUpdating = True
End Sub

Basically, it search through the whole document, looking for any passage using a specific heading style, then copy it along with everything underneath to a new document, and save it. I don't fully get the logic behind it, but it seems to do the job pretty well.

However, now I ran into another problem: this macro will make every save the same file, overriding each other. At the end of the day, there's only 1 "chapter.docx" file, and it contain the very last section the macro copied.

Is there a way for it to save every find into a separate file, with each having a sequence number, such as "chapter (1).docx," "chapter (2).docx," etc.?

[gmayor]

Based on your macro, the following will work, however if this is the result of a mail merge - see https://www.gmayor.com/MergeAndSplit.htm

Option Explicit

Sub SplitChapterByHeading()


Application.ScreenUpdating = False
Dim Rng As Range
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 FilePath As String
Dim fName As String

ActiveDocument.Save
If ActiveDocument.path = "" Then Exit Sub

FilePath = ActiveDocument.path & "\Splited Document\"


'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"

CreateFolders FilePath

With ActiveDocument.Range
Do
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = "Heading " & HeadingName
.Format = True
.Forward = True
.MatchCase = True
.Wrap = wdFindStop
.MatchWildcards = False
.Execute
End With

If .Find.Found = True Then
Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Rng.Select
Selection.Copy
Documents.Add
Selection.Paste
fName = FileNameUnique(FilePath, "chap", ".docx")
ActiveDocument.SaveAs FileName:=FilePath & fName
ActiveDocument.Close
End If
Loop While .Find.Found
End With
Application.ScreenUpdating = True
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018
'strPath is the path in which the file is to be saved
'strFilename is the filename to check
'strExtension is the extension of the filename to check
Dim lng_F As Long
Dim lng_Name As Long
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Do Until Right(strPath, 1) = "\"
strPath = strPath & "\"
Loop
If InStr(1, strFileName, "\") > 0 Then
strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1)
End If
strExtension = Replace(strExtension, Chr(46), "")
lng_F = 1
If InStr(1, strFileName, strExtension) > 0 Then
lng_Name = Len(strFileName) - (Len(strExtension) + 1)
Else
lng_Name = Len(strFileName)
End If
strFileName = Left(strFileName, lng_Name)
'If the filename exists, add or increment a number to the filename
'and keep checking until a unique name is found
Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
If Right(strFileName, 1) = ")" Then strFileName = Split(strFileName, "(")(0)
strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")"
lng_F = lng_F + 1
Loop
'Reassemble the filename
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lng_PathSep = InStr(3, strPath, "\")
If lng_PathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
If lng_PathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lng_PathSep = 0
If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
oFSO.createfolder Left(strPath, lng_PathSep)
End If
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub