Macro Help

Question

I have a Macro that I have used for a while and it does excellent for what I need which is split a document into seperate documents and rename them to the first line of the page.  I have one more tweak that I need though.  I need the header to be carried over to each new document as well.  Is there a way to do this?

THANK YOU!!!

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

'Work on the active document (the one currently containing the Selection):

    Set docMultiple = ActiveDocument

'instantiate the range object:

    Set rngPage = docMultiple.Range

    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 end of range to the point between the pages:

            rngPage.End = Selection.Start

        End If

        rngPage.Copy                    'copy page to clipboard

        Set docSingle = Documents.Add   'create a new document

        docSingle.Range.Paste           'paste to new document

'remove any manual page break to prevent a second blank:

        docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""

'Get first paragraph of the new doc:

        strNewFileName = docSingle.Paragraphs(1).Range.Text

'Remove multiple spaces:

        While InStr(strNewFileName, "  ") > 0

            strNewFileName = Replace(strNewFileName, "  ", " ")   'replace 2 spaces with 1

        Wend

'Remove carriage return:

        strNewFileName = Replace(strNewFileName, Chr(13), "")

'Add file extension:

        strNewFileName = strNewFileName & ".doc"

'save the new single-paged document (NEED TO SPECIFY FileFormat TO SAVE AS .doc):

        docSingle.SaveAs strNewFileName, FileFormat:=wdFormatDocument

        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

Answer 1

Replace

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

     'Work on the active document (the one currently containing the Selection):

    Set docMultiple = ActiveDocument

with

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

    Dim rngHeader as Range

    Application.ScreenUpdating = False

     'Work on the active document (the one currently containing the Selection):

    Set docMultiple = ActiveDocument

    Set rngHeader = docMultiple.Sections(1).Headers(wdHeaderFooterPrimary).Range

    rngHeader.End = rngHeader.End - 1 'Remove the final paragraph mark as it is not wanted.

and then replace

        rngPage.Copy                    'copy page to clipboard

        Set docSingle = Documents.Add   'create a new document

        docSingle.Range.Paste           'paste to new document

with

        rngPage.Copy                    'copy page to clipboard

        Set docSingle = Documents.Add   'create a new document

        docSingle.Range.Paste           'paste to new document

        docSingle.Sections(1).Headers(wdHeaderFooterPrimary).Range = rngHeader