Addition to Split Document Code (by Macropod)

JingleBelle · #1 04-03-2025, 09:00 AM

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.

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 · #2 04-03-2025, 02:28 PM

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 · #3 04-04-2025, 05:32 AM

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.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Adapting Macropod's Acronym Word VBA Code for Excel	scienceguy	Excel Programming	3	11-20-2021 06:59 AM
split word document based on bookmarks with each new document title of the bookmark	megatronixs	Word VBA	9	09-05-2020 02:29 PM
Mail Merge - split merged documents and rename each split document based on text in header	FuriousD	Word VBA	1	05-12-2019 04:06 AM
Pizza Tips - Simple Addition In Word Document	StephenRay	Word VBA	8	09-12-2017 07:13 AM
How do I see one document map for each half of a split MS WORD 2010 document?	quickwin	Word	3	07-09-2013 10:20 PM