Addition to Split Document Code (by Macropod)

[JingleBelle]

I was tasked with splitting many documents into separate files. I was relieved to find Macropod's code (from 2015 on this forum) to split documents at a specified heading levels and it has worked perfectly (no surprise there).

I am hoping someone here would help me update the code so that it would give me a count of the new documents created, via a message box, once the sub has completed. This way I would not have to count the number of files and compare them to the original document's table of contents. It is a minor inconvenience, but it has left me curious nonetheless. I spent the better part of this morning googling and, thus far, I've been unable to find anything specific to what I need. Even if I did find something, I'm not sure I would know how to add it without breaking the code.

Sub SplitDoc2()
''*Sub Name:  SplitDocLev2
'* Author:       Macropod
'* Date:         November 16, 2015
'* Notes:       Splits Docs into Separate Files at Heading Level 2

Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String, Rng As Range, i As Long, Doc As Document
Const StrNoChr As String = """*./\:?|"
With ActiveDocument
  StrTmplt = .AttachedTemplate.FullName
  StrPath = .Path & "\"
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Style = wdStyleHeading2  'Change level here
      .Format = True
      .Forward = True
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      Set Rng = .Duplicate
      StrFlNm = Split(Rng.Paragraphs(1).Range.Text, vbCr)(0)
      For i = 1 To Len(StrNoChr)
        StrFlNm = Replace(StrFlNm, Mid(StrNoChr, i, 1), "_")
      Next
      StrFlNm = StrFlNm & ".docx"
      Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
      Set Doc = Documents.Add(Template:=StrTmplt, Visible:=False)
      With Doc
        .Range.FormattedText = Rng.FormattedText
        .SaveAs2 Filename:=StrPath & StrFlNm, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
         On Error Resume Next 
        .Close False
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

[macropod]

Simple!

Change
i As Long,
to
i As Long , j As Long,

Change
Set Rng = .Duplicate
to
Set Rng = .Duplicate: j = j +1

Change
Set Rng = Nothing
to
Set Rng = Nothing: MsgBox j & " documents created", vbInformation

[JingleBelle]

Macropod,

First, thank you for the original code! It has been so helpful. Second, thank you for taking the time to respond to my request. I tested it this morning, and it works perfectly (again, no surprise). This is fantastic!

The additions will help me easily identify instances when fewer files than expected are created. I discovered this is caused by two identical file names (because the headings were identical) where the second overwrites the first. It's rare but has happened.

I can't thank you enough for your expertise and willingness to help me and others who frequent this forum.