Originally Posted by macropod
If you want to preserve each document's headers etc, then you have to include code to do that. And, if the page layouts differ, you need code for that also. For a fairly comprehensive example, try the following. If the page layouts are the same, you won't need the second sub; otherwise, use both and uncomment the 'Call' line:
[VBA]Sub ImportDocument()
Application.ScreenUpdating = False
Dim wdDoc As Document, strFile As String, Rng As Range, HdFt As HeaderFooter, i As Long
'strFile = "C:\Users\Macropod\Documents\Attachments\Faces.docx"
strFile = "C:\Documents and Settings\lorien\My Documents\zen.doc"
With ActiveDocument
'If there is more than one Section, unlink the headers & footers from the 1st Section
' so that the new Section's content won't impact subsequent Sections
If .Sections.Count > 1 Then
With .Sections(2)
For Each HdFt In .Headers
HdFt.LinkToPrevious = False
Next
For Each HdFt In .Footers
HdFt.LinkToPrevious = False
Next
End With
End If
Set Rng = .Sections(1).Range
With Rng
'If there's already a Section break, move back one character
If Asc(.Characters.Last) = 12 Then
.End = .End - 1
End If
'Ensure there's an empty paragraph for the new Section.
While Asc(.Characters.Last.Previous) <> 13
.InsertAfter vbCr
Wend
.MoveEnd wdCharacter, -1
.Collapse wdCollapseEnd
End With
'Add the new Section
.Sections.Add Range:=Rng, Start:=wdSectionNewPage
' Unlink the headers & footers from the 1st Section
' so that the new Section's content won't impact first Section
With .Sections(2)
'Insert the new content, retaining its formatting
Set wdDoc = Documents.Open(FileName:=strFile, AddToRecentFiles:=False, Visible:=False)
For Each HdFt In .Headers
HdFt.LinkToPrevious = False
Next
For Each HdFt In .Footers
HdFt.LinkToPrevious = False
Next
Set Rng = .Range
Rng.Collapse wdCollapseStart
With wdDoc
.Range.Copy
Rng.PasteAndFormat Type:=wdFormatOriginalFormatting
i = .Sections.Count
'Call ReplicateLayout(wdDoc.Sections(i), ActiveDocument.Sections(i + 1))
For Each HdFt In .Sections(i).Headers
With ActiveDocument.Sections(i + 1)
If .Headers(HdFt.Index).Exists Then
.Headers(HdFt.Index).Range.Copy
HdFt.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
.Headers(HdFt.Index).Range.Characters.Last.Delete
End If
End With
Next
For Each HdFt In .Sections(i).Footers
With ActiveDocument.Sections(i + 1)
If .Footers(HdFt.Index).Exists Then
.Headers(HdFt.Index).Range.Copy
HdFt.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
.Footers(HdFt.Index).Range.Characters.Last.Delete
End If
End With
Next
.Close SaveChanges:=False
End With
End With
End With
Set wdDoc = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub[/VBA]
