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