Merging Documents into a New Document

[plakatown]

Merging multiple documents is often rather more complex than simply copying & pasting content from one document to another. Problems arise when the documents have different page layouts, headers, footers, page numbering, bookmarks & cross-references, Tables of Contents, Indexes, etc., etc., and especially when those documents have used the same Style names with different definitions. The compromises can be mitigated, though.

The following macro handles the more common issues that arise when merging documents; it does not attempt to resolve page numbering, Tables of Contents or Indexes. Neither does it attempt to deal with the effects on footnote or endnote numbering & positioning or with the consequences of duplicated bookmarks (only one of which can exist in the merged document) and any corresponding cross-references.

The macro includes a folder browser. Simply select the folder to process and all documents from that folder will be merged into the active document.

Sub MergeDocuments()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Dim strFolder As String, strFile As String
Dim DocSrc As Document, DocTgt As Document
Dim strDocNm As String, Rng As Range, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set DocTgt = ActiveDocument
strDocNm = DocTgt.FullName
strFile = Dir(strFolder & "\*.doc")
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set DocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With DocTgt
Set Rng = .Range.Characters.Last
With Rng
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse wdCollapseEnd
Call LayoutTransfer(DocSrc, DocTgt)
.FormattedText = DocSrc.Range.FormattedText
End With
For Each HdFt In .Sections.Last.Headers
HdFt.LinkToPrevious = False
HdFt.Range.Text = vbNullString
Next
For Each HdFt In .Sections.Last.Footers
HdFt.LinkToPrevious = False
HdFt.Range.Text = vbNullString
Next
For Each HdFt In .Sections(.Sections.Count - 1).Headers
With HdFt.Range
.FormattedText = DocSrc.Sections.Last.Headers(HdFt.Index).Range.FormattedText
.Characters.Last.Delete
End With
Next
For Each HdFt In .Sections(.Sections.Count - 1).Footers
With HdFt.Range
.FormattedText = DocSrc.Sections.Last. Footers(HdFt.Index).Range.FormattedText
.Characters.Last.Delete
End With
Next
End With
DocSrc.Close False
End If
strFile = Dir()
Wend
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True
End Sub
Sub LayoutTransfer(DocSrc As Document, DocTgt As Document)
'Document Body variables
Dim sPageHght As Single, sPageWdth As Single
Dim sHeaderDist As Single, sFooterDist As Single
Dim sTMargin As Single, sBMargin As Single
Dim sLMargin As Single, sRMargin As Single
Dim sGutter As Single, sGutterPos As Single
Dim lPaperSize As Long, lGutterStyle As Long
Dim lMirrorMargins As Long, lVerticalAlignment As Long
Dim lScnStart As Long, lScnDir As Long
Dim lOddEvenHdFt As Long, lDiffFirstHdFt As Long
Dim bTwoPagesOnOne As Boolean, bBkFldPrnt As Boolean
Dim bBkFldPrnShts As Boolean, bBkFldRevPrnt As Boolean
Dim bOrientation As Boolean
'Get Page Setup parameters
With DocSrc.Sections.First.PageSetup
lPaperSize = .PaperSize
lGutterStyle = .GutterStyle
bOrientation = .Orientation
lMirrorMargins = .MirrorMargins
lScnStart = .SectionStart
lScnDir = .SectionDirection
lOddEvenHdFt = .OddAndEvenPagesHeaderFooter
lDiffFirstHdFt = .DifferentFirstPageHeaderFooter
lVerticalAlignment = .VerticalAlignment
sPageHght = .PageHeight
sPageWdth = .PageWidth
sTMargin = .TopMargin
sBMargin = .BottomMargin
sLMargin = .LeftMargin
sRMargin = .RightMargin
sGutter = .Gutter
sGutterPos = .GutterPos
sHeaderDist = .HeaderDistance
sFooterDist = .FooterDistance
bTwoPagesOnOne = .TwoPagesOnOne
bBkFldPrnt = .BookFoldPrinting
bBkFldPrnShts = .BookFoldPrintingSheets
bBkFldRevPrnt = .BookFoldRevPrinting
End With
'Set Page Setup parameters
With DocTgt.Sections.Last.PageSetup
.GutterStyle = lGutterStyle
.MirrorMargins = lMirrorMargins
.SectionStart = lScnStart
.SectionDirection = lScnDir
.OddAndEvenPagesHeaderFooter = lOddEvenHdFt
.DifferentFirstPageHeaderFooter = lDiffFirstHdFt
.VerticalAlignment = lVerticalAlignment
.PageHeight = sPageHght
.PageWidth = sPageWdth
.TopMargin = sTMargin
.BottomMargin = sBMargin
.LeftMargin = sLMargin
.RightMargin = sRMargin
.Gutter = sGutter
.GutterPos = sGutterPos
.HeaderDistance = sHeaderDist
.FooterDistance = sFooterDist
.TwoPagesOnOne = bTwoPagesOnOne
.BookFoldPrinting = bBkFldPrnt
.BookFoldPrintingSheets = bBkFldPrnShts
.BookFoldRevPrinting = bBkFldRevPrnt
.PaperSize = lPaperSize
.Orientation = bOrientation
End With
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

I have used the above code from http://www.vbaexpress.com/forum/showthread.php?51797-Macro-to-merge-mulitple-word-doc-into-one-word-doc in my word document and added Documents.Add in the first line to open the merged document in a new file.
However, I noticed that the first page of the new document is always a blank page followed by the merged word files.
So I would like to know if there is any way to get rid of the first blank page and the page number of the merged word files as well?
Thanks.

[macropod]

To eliminate the blank page, after:
Wend
insert:
ActiveDocument.Sections.First.Range.Delete

As for the page numbering, that can be problematic if any of the source documents has its own header/footer content and/or the different sections have differing pagination arrangements and/or orientations. Besides which, you haven't said where or in what format the numbers would appear.

[plakatown]

To eliminate the blank page, after:

Wend
insert:
ActiveDocument.Sections.First.Range.Delete

As for the page numbering, that can be problematic if any of the source documents has its own header/footer content and/or the different sections have differing pagination arrangements and/or orientations. Besides which, you haven't said where or in what format the numbers would appear.

Thanks.
I also managed to remove the headers and footers (where the page numbers exist) by adding the following codes right behind
ActiveDocument.Sections.First.Range.Delete



Dim oSec As Section
Dim oHead As HeaderFooter
Dim oFoot As HeaderFooter
For Each oSec In ActiveDocument.Sections
For Each oHead In oSec.Headers
If oHead.Exists Then oHead.Range.Delete
Next oHead
For Each oFoot In oSec.Footers
If oFoot.Exists Then oFoot.Range.Delete
Next oFoot
Next oSec

[macropod]

That's OK - it wasn't apparent to me whether there was any existing header/footer content you wanted to preserve. Apparently not. Rather than deleting the text, as such, all you need do is ensure each header/footer is linked to the previous one - which your present code doesn't do. That way, when you add the page #s to the header(s)/footer(s) in the first Section, you can be sure they'll appear in all Sections.