尝试使用VBA实现Word中文档拆分的自动化

Question

我试图通过VBA来自动化我的团队和我自己目前手工完成的一个过程--获取一个Word文档并根据H1部分将其拆分为多个文档(我的意思是，如果一个文档有6个H1s，那么我们就会得到6个文档)。

我已经找到了一些运行良好的代码，但是有几个部分我不太清楚。

1. 从原始文档中获取页脚以显示在子文档中，
2. 在每个文件名的开头添加一个序列号。

前一个要求非常简单--我的原始文档有一个页脚，我希望代码输出的文档具有相同的页脚。现在，生成的文件具有空白页脚。后一个要求是，我最终希望新文件具有格式为"XX - HeadingText.docx“的文件名。我正在使用的代码使我得到了标题文本，但我似乎无法插入顺序编号。

这是我正在使用的代码，任何帮助都将不胜感激！

    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

尝试：

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