Combine Multiple Word Documents

[macropod]

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 macros handle the more common issues that arise when combining documents; they do 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 do they 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.



Only document content is processed - VBA code (macros) in the source documents is not processed. Similarly, source documents that are mailmerge main documents will no longer have their data connections in the destination document. If the destination document is itself a mailmerge main document, its data connection will be retained and will apply to the mergefields imported from the source documents.

There are three code blocks below beginning with macros titled:
• CombineSelectedDocuments;
• CombineFolderDocuments; and
• AddDocument.
Depending on your requirements and operating system, you would use either of the first two code blocks. Both of those require the AddDocument code block.

The CombineSelectedDocuments macro, which works on PCs and Macs alike, allows you to select the documents to be combined. Simply select the files to process and they will be combined into the currently-active document. A limitation with Macs is that they can't disable Auto Macros using WordBasic the way Windows PCs can. Accordingly, if you're going to combine documents on a Mac and those documents contain Auto Macros that require user input, in the AddDocument sub you will need to change the line:

Set wdDocSrc = Documents.Open(FileName:=strSrc, AddToRecentFiles:=False, Visible:=False)

to:

Set wdDocSrc = Documents.Open(FileName:=strSrc, AddToRecentFiles:=False, Visible:=True)

The CombineFolderDocuments macro, which works on Windows PCs only, includes a folder browser. Simply select the folder to process and all documents in that folder will be combined into the currently-active document.

In either case, Word's .doc, .docx, and .docm formats will all be processed, even if different formats exist in the selected list or selected folder.

As coded, the combined document will be saved with ' - Combined' appended to the filename and closed. If you want the document to remain open, simply comment-out or delete the line:

.Close SaveChanges:=False

If you don't want the combined document to have ' - Combined' appended to the filename, simply omit ' - Combined' from the code. And, if you don't want the combined document to be save at all, simply comment-out or delete the entire code segment:

  With ActiveDocument
    ' 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
End With

Sub CombineSelectedDocuments()
'Sourced from: https://www.msofficeforums.com/word-vba/43339-combine-multiple-word-documents.html
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
#If Not Mac Then Application.WordBasic.DisableAutoMacros True: #End If
Dim i As Long
With Application.FileDialog(msoFileDialogFilePicker)
  .AllowMultiSelect = True
  .Filters.Clear
  .Filters.Add "Word Documents", "*.doc;*.docx;*.docm"
  If .Show = -1 Then
    For i = 1 To .SelectedItems.Count
      Call AddDocument(ActiveDocument, .SelectedItems(i)): DoEvents
    Next i
  End If
  With ActiveDocument
    ' 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
End With
#If Not Mac Then Application.WordBasic.DisableAutoMacros False: #End If
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True
End Sub

Sub CombineFolderDocuments()
'Sourced from: https://www.msofficeforums.com/word-vba/43339-combine-multiple-word-documents.html
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Application.WordBasic.DisableAutoMacros True
Dim strFolder As String, StrFile As String, strTgt As String, strSrc As String
strFolder = GetFolder: If strFolder = "" Then Exit Sub
strTgt = ActiveDocument.FullName: StrFile = Dir(strFolder & "\*.doc", vbNormal)
While StrFile <> ""
  strSrc = strFolder & "\" & StrFile
  If strSrc <> strTgt Then Call AddDocument(ActiveDocument, strSrc): DoEvents
  StrFile = Dir()
Wend
With ActiveDocument
  ' 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
Application.WordBasic.DisableAutoMacros False
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True
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

Sub AddDocument(wdDocTgt As Document, strSrc As String)
'Sourced from: https://www.msofficeforums.com/word-vba/43339-combine-multiple-word-documents.html
Dim strFolder As String, StrFile As String, strTgt As String
Dim wdDocSrc As Document, HdFt As HeaderFooter
Set wdDocSrc = Documents.Open(FileName:=strSrc, 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
Set wdDocSrc = Nothing
Application.ScreenUpdating = True
End Sub

Sub LayoutTransfer(wdDocTgt As Document, wdDocSrc As Document)
'Sourced from: https://www.msofficeforums.com/word-vba/43339-combine-multiple-word-documents.html
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

With the AddDocument code block:
• You can omit 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:

Dim wdDocSrc As Document, HdFt As HeaderFooter

to:

Dim wdDocSrc As Document, HdFt As HeaderFooter, Fld As Field

and insert:

            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:

            .Range.Characters.Last.Delete

For PC macro installation & usage instructions, see: Installing Macros
For Mac macro installation & usage instructions, see: https://wordmvp.com/Mac/InstallMacro.html