Trying to use VBA to Automate Document Splitting in Word - vba

Question

I am trying to VBA my way into automating a process that my team and myself currently do manually-- taking a Word document and splitting it into multiple documents based on H1 sections (by which I mean, if a doc has 6 H1s, then we wind up with 6 documents).
I have found some code that works well enough, but there are a couple pieces that I can't quite puzzle out.
Getting the footers from my original document to show up in the subdocuments, and
adding a sequential number at the start of each file name.
The former requirement is pretty simple-- my original doc has a footer on it, and I'd like the documents that the code spits out to have the same footer. Right now, the resulting files have blank footers. The latter requirement is that I ultimately would like the new files to have file names with the format "XX - [HeadingText].docx". The code I'm using gets me the heading text just fine, but I can't seem to plug in the sequential numbering.
Here's the code I'm using; any help would be appreciated!
Sub SeparateHeadings()
'
' SeparateHeadings Macro
'
'
Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String, Rng As Range, Doc As Document, i As Long
Dim iTemp As Integer
With ActiveDocument
StrTmplt = .AttachedTemplate.FullName
StrPath = .Path & "\"
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = "Heading 1"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range.Duplicate
With Rng
StrFlNm = Replace(.Text, vbCr, "")
For i = 1 To 255
Select Case i
Case 1 To 31, 33, 34, 37, 42, 44, 46, 47, 58 - 63, 91 - 93, 96, 124, 147, 148
StrFlNm = Replace(StrFlNm, Chr(i), "")
End Select
Next
iTemp = iTemp + 1
Do
If .Paragraphs.Last.Range.End = ActiveDocument.Range.End Then Exit Do
Select Case .Paragraphs.Last.Next.Style
Case "Heading 1"
Exit Do
Case Else
.MoveEnd wdParagraph, 1
End Select
Loop
End With
Set Doc = Documents.Add(Template:=StrTmplt, Visible:=False)
With Doc
.Range.FormattedText = Rng.FormattedText
.SaveAs2 FileName:=StrPath & StrFlNm, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

Answer 1

Try:
Sub SplitDocByHeading1()
Application.ScreenUpdating = False
Dim StrTmplt As String, StrPath As String, StrFlNm As String
Dim Rng As Range, i As Long, j As Long, Doc As Document
Const StrNoChr As String = """*./\:?|"
With ActiveDocument
StrTmplt = .FullName
StrPath = .Path & "\"
'Convert auto numbering to static numbering
.ConvertNumbersToText (wdNumberAllNumbers)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Style = wdStyleHeading1
.Format = True
.Forward = True
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found
Set Rng = .Duplicate: i = i + 1
StrFlNm = Split(Rng.Paragraphs(1).Range.Text, vbCr)(0)
For j = 1 To Len(StrNoChr)
StrFlNm = Replace(StrFlNm, Mid(StrNoChr, j, 1), "_")
Next
StrFlNm = Format(i, "00") & "_" & 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
.Close False
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Set Doc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub