Trying to use VBA to Automate Document Splitting in Word

问题

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.

1. Getting the footers from my original document to show up in the subdocuments, and
2. 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

回答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

来源：https://stackoverflow.com/questions/66013917/trying-to-use-vba-to-automate-document-splitting-in-word