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