Hello everyone,
According to this article,

https://www.msofficeforums.com/word-...save-file.html

Dear Paul,
How to copy a selected range of the document to a new document with preserving formatting, header, and footer of the original document?

With special thank

Do you need this in Word or would a PDF output work for you? Printing a range to PDF will give you an exact extract.

Staying in Word, the simplest way is to SaveAs to produce a duplicate file and then delete content before and after the desired range. Even then there are issues to be aware of. For instance, the page setup and header/footers might change if there are section breaks after the desired range so you might want the code to handle that scenario. Cross-refs may break and autonumbered items may change numbers, figures or table numbers restart etc.

__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia

Dear Andrew, thank you for your comment
I prefer in word doc, because many VBA codes are available online for this purpose.

Currently, I use this code to copy selected range to a new doc, but it just copy selected without header and footer

Also, I use this code to copy selected range to pdf, but also without header and footer

Additionally, this code export the selected range of pages in pdf format with header and footer, but you need to insert the range manually each run of the code which may be annoying



hence, I want to export it in word doc, as Mr. Paul split the document by heading with header and footer.

Thank you

Hi, I believe Cindy Meister MVP published this in the German Programming Book which I bought years ago and the update.

Read it carefully and you should be able to choose what formatting you wish to copy.

Select the part of the document you wish to copy first. Then run the macro.

It seems to be what you are after.

Option Explicit
Sub Save_Selection_To_New_File()
'(Cindy Meister - German Programming Handbook)

'Variable declaration
Dim rngSel As Word.Range
Dim origSetup As Word.PageSetup
Dim docNew As Word.Document
Dim oDoc As Document
Dim Title As String
Dim Msg As String
Dim Response As VbMsgBoxResult
Title = "Save Selection to New File with Page Layout Format"
Set oDoc = ActiveDocument

'Stop if no text selected
If oDoc.Bookmarks("\Sel").Range.text = "" Then
Msg = "Before running the command, you must select the text you want to " & _
"copy for insertion in a New File."
MsgBox Msg, vbOKOnly, Title
GoTo ExitHere
End If

Msg = "Use this command if you need to copy part of a document to a New File " & _
"and retain page layout and format." & vbCr & vbCr & _
"When the command is finished save the document."

Response = MsgBox(Msg, vbOKCancel, Title)

'Stop if the user does not click OK
If Response <> vbOK Then GoTo ExitHere

'Assign the selection to its variable
Set rngSel = Selection.Range
Set origSetup = rngSel.Sections(1).PageSetup
'Create a new document from the current document
'So that styles, etc. are all present
Set docNew = Documents.Add(ActiveDocument.FullName)
'Delete everything
docNew.Range.Delete
'Put the selection into the new document
docNew.Range.FormattedText = rngSel.FormattedText

'Set the page properties to correspond
'to the settings for the section in which
'the selection was made

'"With" allows multiple properties of an object to be set
'by treating the words on the With line as a prefix for the
'lines that start with a .(period) that follow. The With
'must be ended.
With docNew.Sections(1).PageSetup
.BottomMargin = origSetup.BottomMargin
.TopMargin = origSetup.TopMargin
.LeftMargin = origSetup.LeftMargin
.RightMargin = origSetup.RightMargin
.Gutter = origSetup.Gutter
'Comment out the next two lines for Wor97
'and Word 2000
.GutterPos = origSetup.GutterPos
.GutterStyle = origSetup.GutterStyle
.DifferentFirstPageHeaderFooter = _
origSetup.DifferentFirstPageHeaderFooter
.OddAndEvenPagesHeaderFooter = _
origSetup.OddAndEvenPagesHeaderFooter
.FooterDistance = origSetup.FooterDistance
.HeaderDistance = origSetup.HeaderDistance
.MirrorMargins = origSetup.MirrorMargins
.Orientation = origSetup.Orientation
.PaperSize = origSetup.PaperSize
.PageHeight = origSetup.PageHeight
.PageWidth = origSetup.PageWidth
'"With" allows multiple properties of an object to be set
'by treating the words on the With line as a prefix for the
'lines that start with a .(period) that follow. The With
'must be ended. With statements may be nested.
With .TextColumns
.SetCount NumColumns:=origSetup.TextColumns.Count
.EvenlySpaced = origSetup.TextColumns.EvenlySpaced
.LineBetween = origSetup.TextColumns.LineBetween
If .Count > 1 And .EvenlySpaced Then
'Variable declaration
Dim i As Long
.Spacing = origSetup.TextColumns.Spacing
If .Spacing = False Then
For i = 1 To .Count
.Item(i).SpaceAfter = _
origSetup.TextColumns(i).SpaceAfter
.Item(i).Width = _
origSetup.TextColumns(i).Width
Next
End If
ElseIf .Count > 1 And Not .EvenlySpaced Then
For i = 1 To .Count
.Width = origSetup.TextColumns(i).Width
Next
End If
End With
End With

'Define headers, footers and page numbers
Dim pgNr As Long
'Get the starting page number
rngSel.Collapse wdCollapseStart
pgNr = rngSel.Information(wdActiveEndAdjustedPageNumber)
'Disables different first page if selection is not on a first page
'Comment out the following first, and fourth through seventh
' lines to see first page headers/footers
' in result document if present in original even if
' selection is not originally on a first page
If pgNr = 1 Then
ProcessHeadersFooters wdHeaderFooterFirstPage, _
rngSel.Sections(1), docNew.Sections(1)
Else
docNew.Sections(1).PageSetup. _
DifferentFirstPageHeaderFooter = False
End If
'To NOT retain the original page number,
'comment out the next four lines

'"With" allows multiple properties of an object to be set
'by treating the words on the With line as a prefix for the
'lines that start with a .(period) that follow. The With
'must be ended.

With docNew.Sections(1).Headers(wdHeaderFooterPrimary)
.PageNumbers.RestartNumberingAtSection = True
.PageNumbers.StartingNumber = pgNr
End With

ProcessHeadersFooters wdHeaderFooterPrimary, _
rngSel.Sections(1), docNew.Sections(1)
ProcessHeadersFooters wdHeaderFooterEvenPages, _
rngSel.Sections(1), docNew.Sections(1)

'Display the FileSaveAs dialog box - NOT IN USE***
'Dialogs(wdDialogFileSaveAs).Show

Msg = "Finished. Read the Status Line (bottom left corner). You may now save the new file."
MsgBox Msg, vbOKOnly, Title

ExitHere:
'Clean up
Set oDoc = Nothing
End Sub

'Carry over formatted text for the selected section
'from original document and update the fields

Sub ProcessHeadersFooters(typ As Long, _
sec1 As Word.Section, sec2 As Word.Section)

sec2.Headers(typ).Range.FormattedText = _
sec1.Headers(typ).Range.FormattedText
sec2.Headers(typ).Range.Fields.Update
sec2.Footers(typ).Range.FormattedText = _
sec1.Footers(typ).Range.FormattedText
sec2.Footers(typ).Range.Fields.Update
End Sub

The macro needs updating in Office 365 it copies whole document (regardless of selection) in some US formatted documents.

jec1
Looking at the code, it appears to cover what the user asked for and should work quite well. I'm not sure why you might be seeing a problem with Office 365 - the code 'should' work equally well on that version unless it is erroring on the third line here.

__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia

Thank you for your reply,
but I face this issue

A.png

That chunk is pointing at a function/sub that we didn't get as part of the code. You can disable the line by placing a ' at the start of the line.

The functionality this line provides is most likely to copy the first page header/footer if required. It will actually be quite rare that you need that.

__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia

You are missing the ProcessHeaderFooters function code, which no doubt you will find where you found the rest of the code.

__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com

Thank you I certainly did find the balance of the code.
I was busy and missed it - hard to do 6 things at once....

Thank you for all
Best Wishes