Users occasionally need to combine multiple documents that may of may not have the same page layouts, Style definitions, and so on. Consequently, combining 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 following Word macro (
for Windows PCs only) handles the more common issues that arise when combining documents; it does not attempt to resolve conflicts with paragraph auto-numbering, document -vs- section page numbering in 'page x of y' numbering schemes, Tables of Contents or Indexing issues. Neither does it attempt to deal with the effects on footnote or endnote numbering & positioning (additional code would be required for that) or with the consequences of duplicated bookmarks (only one of which can exist in the combined document) and any corresponding cross-references.
The macro includes a folder browser. Simply select the folder to process and all documents in that folder will be combined into the currently-active document. Word's .doc, .docx, and .docm formats will all be processed, even if different formats exist in the selected folder.
Code:
Sub CombineDocuments()
'Sourced from: https://www.msofficeforums.com/word-vba/43339-combine-multiple-word-documents.html
Application.ScreenUpdating = False
Dim strFolder As String, StrFile As String, strTgt As String
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName
StrFile = Dir(strFolder & "\*.doc", vbNormal)
While StrFile <> ""
If strFolder & StrFile <> strTgt Then
Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
With wdDocTgt
.Characters.Last.InsertBefore vbCr
.Characters.Last.InsertBreak (wdSectionBreakNextPage)
With .Sections.Last
For Each HdFt In .Headers
With HdFt
.LinkToPrevious = False
.Range.Text = vbNullString
.PageNumbers.RestartNumberingAtSection = True
.PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
End With
Next
For Each HdFt In .Footers
With HdFt
.LinkToPrevious = False
.Range.Text = vbNullString
.PageNumbers.RestartNumberingAtSection = True
.PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
End With
Next
End With
Call LayoutTransfer(wdDocTgt, wdDocSrc)
.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText
With .Sections.Last
For Each HdFt In .Headers
With HdFt
.Range.FormattedText = wdDocSrc.Sections.Last.Headers(.Index).Range.FormattedText
.Range.Characters.Last.Delete
End With
Next
For Each HdFt In .Footers
With HdFt
.Range.FormattedText = wdDocSrc.Sections.Last.Footers(.Index).Range.FormattedText
.Range.Characters.Last.Delete
End With
Next
End With
End With
wdDocSrc.Close SaveChanges:=False
End If
StrFile = Dir()
Wend
With wdDocTgt
' Save & close the combined document
.SaveAs FileName:=Split(strTgt,".doc")(0) & " - Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=Split(strTgt,".doc")(0) & " - Combined.pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Sub LayoutTransfer(wdDocTgt As Document, wdDocSrc As Document)
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 lOrientation As Long
With wdDocSrc.Sections.Last.PageSetup
lPaperSize = .PaperSize
lGutterStyle = .GutterStyle
lOrientation = .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
With wdDocTgt.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 = lOrientation
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
You could even do away with the 'LayoutTransfer' sub and the call to it if you can be confident all the documents have the same page layout.
If some or all of your source documents do have a 'page x of y' numbering scheme and only one Section in them, you could change:
Code:
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter
to:
Code:
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter, Fld As Field
and insert:
Code:
For Each Fld In .Range.Fields
If Fld.Type = wdFieldNumPages Then Fld.Code.Text = Replace(Fld.Code.Text, "NUMPAGES", "SECTIONPAGES")
Next
after both instances of:
Code:
.Range.Characters.Last.Delete
For PC macro installation & usage instructions, see:
Installing Macros