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