在 vba 代码中保留页眉/页脚以进行文档拆分

Question

我在网上找到了完全符合我期望的代码，但是我正在寻找一种方法来保留页眉和页脚。现在它只需要小主体并在复制到新文档时删除页眉和页脚。我不手动执行此操作的原因是因为有超过 200 页。通过查看代码，我认为它可能与扩大它读取的范围有关。

Sub SplitIntoPages()
Dim docMultiple As Document
Dim docSingle As Document
Dim rngPage As Range
Dim iCurrentPage As Integer
Dim iPageCount As Integer
Dim strNewFileName As String
Application.ScreenUpdating = False 'Makes the code run faster and reduces screen _
flicker a bit.
Set docMultiple = ActiveDocument 'Work on the active document _
(the one currently containing the Selection)
Set rngPage = docMultiple.Range 'instantiate the range object
iCurrentPage = 1
'get the document's page count
iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)
Do Until iCurrentPage > iPageCount
If iCurrentPage = iPageCount Then
rngPage.End = ActiveDocument.Range.End 'last page (there won't be a next page)
Else
'Find the beginning of the next page
'Must use the Selection object. The Range.Goto method will not work on a page
Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
'Set the end of the range to the point between the pages
rngPage.End = Selection.Start
End If
rngPage.Copy 'copy the page into the Windows clipboard
Set docSingle = Documents.Add 'create a new document
docSingle.Range.Paste 'paste the clipboard contents to the new document
'remove any manual page break to prevent a second blank
docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
'build a new sequentially-numbered file name based on the original multi-paged file name and path
strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")
docSingle.SaveAs strNewFileName 'save the new single-paged document
iCurrentPage = iCurrentPage + 1 'move to the next page
docSingle.Close 'close the new document
rngPage.Collapse wdCollapseEnd 'go to the next page
Loop 'go to the top of the do loop
Application.ScreenUpdating = True 'restore the screen updating
'Destroy the objects.
Set docMultiple = Nothing
Set docSingle = Nothing
Set rngPage = Nothing
End Sub

我所拥有的：一致的页眉/页脚，具有可变的主体。

我的期望：VBA 执行并将每一页分成一个新文档。

会发生什么：VBA 将每个主体分解为一个新文档并丢弃页眉/页脚。

Answer 1

文档的页眉/页脚属于section break，而不是单独的页面。所以复制页面内容不能/不会包括页眉/页脚。

一种方法是

• 获取页数
• 根据页数设置循环
• 删除除应保留页面外的所有内容
• 保存文件，将其关闭，重新打开文件并在下一页重复删除

另一种可能性是在新文档中也复制页眉/页脚。我已经用几行代码更改了您的代码（并对其进行了格式化！）。我假设源文档中只有“主要”页眉和页脚 - 没有第一页，甚至没有页面。

    'get the header
    docSingle.Sections(1).Headers(wdHeaderFooterPrimary).Range.FormattedText = _
        rngPage.Sections(1).Headers(wdHeaderFooterPrimary).Range.FormattedText
    'get the footer
    docSingle.Sections(1).Footers(wdHeaderFooterPrimary).Range.FormattedText = _
        rngPage.Sections(1).Footers(wdHeaderFooterPrimary).Range.FormattedText

此代码使用Range.FormattedText 属性来传输数据，而不是使用复制/粘贴。通常，最好避免使用剪贴板并直接进入，尽管规则可能存在例外情况......如果源文档中有多个部分，则此代码应选择要复制页面的部分的页眉/页脚，这就是为什么它使用rngPage 而不是docMultiple 作为源代码的原因。

Sub SplitIntoPages()
    Dim docMultiple As Document
    Dim docSingle As Document
    Dim rngPage As Range
    Dim iCurrentPage As Integer
    Dim iPageCount As Integer
    Dim strNewFileName As String

    Application.ScreenUpdating = False 'Makes the code run faster and reduces screen _
    flicker a bit.
    Set docMultiple = ActiveDocument 'Work on the active document _
    (the one currently containing the Selection)
    Set rngPage = docMultiple.content 'instantiate the range object
    iCurrentPage = 1

    'get the document's page count
    iPageCount = docMultiple.content.ComputeStatistics(wdStatisticPages)
    Do Until iCurrentPage > iPageCount
        If iCurrentPage = iPageCount Then
            rngPage.End = ActiveDocument.Range.End 'last page (there won't be a next page)
        Else
            'Find the beginning of the next page
            'Must use the Selection object. The Range.Goto method will not work on a page
            Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
            'Set the end of the range to the point between the pages
            rngPage.End = Selection.Start
        End If
        'rngPage.Copy 'copy the page into the Windows clipboard

        Set docSingle = Documents.Add 'create a new document
        docSingle.content.FormattedText = rngPage.FormattedText 'carry over the page to the new document
        'remove any manual page break to prevent a second blank
        docSingle.Range.Find.Execute findText:="^m", ReplaceWith:=""
        'get the header
        docSingle.Sections(1).Headers(wdHeaderFooterPrimary).Range.FormattedText = _
            rngPage.Sections(1).Headers(wdHeaderFooterPrimary).Range.FormattedText
        'get the footer
        docSingle.Sections(1).Footers(wdHeaderFooterPrimary).Range.FormattedText = _
            rngPage.Sections(1).Footers(wdHeaderFooterPrimary).Range.FormattedText

        'build a new sequentially-numbered file name based on the original multi-paged file name and path
        strNewFileName = Replace(docMultiple.FullName, ".doc", "_" & Right$("000" & iCurrentPage, 4) & ".doc")
        docSingle.SaveAs strNewFileName 'save the new single-paged document

        iCurrentPage = iCurrentPage + 1 'move to the next page
        docSingle.Close 'close the new document
        Set docSingle = Nothing 'release for the next iteration
        Set rngPage = Nothing
        rngPage.Collapse wdCollapseEnd 'go to the next page
    Loop 'go to the top of the do loop
    Application.ScreenUpdating = True 'restore the screen updating
    'Destroy the objects.
    Set docMultiple = Nothing
End Sub