Microsoft Office Forums Combine Multiple Word Documents

Go Back   Microsoft Office Forums > >

Closed Thread
 
Thread Tools Display Modes
  #1  
Old 09-04-2019, 12:09 AM
macropod's Avatar
macropod macropod is offline Combine Multiple Word Documents Windows 7 64bit Combine Multiple Word Documents Office 2010 32bit
Administrator
Combine Multiple Word Documents
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 19,577
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default Combine Multiple Word Documents

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 macro handles the more common issues that arise when combining documents; it does not attempt to resolve conflicts with paragraph auto-numbering, page numbering, Tables of Contents or Indexing issues. 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 in that folder will be combined into the currently-active document.
Code:
Sub CombineDocuments()
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 & "\*.docx", 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
          End With
        Next
        For Each HdFt In .Footers
          With HdFt
            .LinkToPrevious = False
            .Range.Text = vbNullString
          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:=strFolder & "Forms.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
  ' and/or:
  .SaveAs FileName:=strFolder & "Forms.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
__________________
Cheers,
Paul Edstein
[MS MVP - Word]
  #2  
Old 09-07-2019, 09:26 AM
Charles Kenyon Charles Kenyon is offline Combine Multiple Word Documents Windows 10 Combine Multiple Word Documents Office 2016
Moderator
 
Join Date: Mar 2012
Location: Sun Prairie, Wisconsin
Posts: 6,048
Charles Kenyon is a name known to allCharles Kenyon is a name known to allCharles Kenyon is a name known to allCharles Kenyon is a name known to allCharles Kenyon is a name known to allCharles Kenyon is a name known to all
Default

Thank you. I've saved the macros/function and bookmarked this page so that I can send others here.
Closed Thread

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Need help fixing compile error expected End Sub to combine multiple documents into one (Mac) Vivianweir Excel Programming 3 11-02-2018 02:20 AM
combine 2 different word documents salimnore Word 6 05-29-2018 09:43 AM
Combine Multiple Word Documents best approach to combine documents being created by multiple users jwalke123 Word 5 08-08-2015 03:27 PM
Cross-referencing in multiple documents that will combine to make one report razberri Word 1 01-20-2014 01:00 AM
combine multiple documents word starter 2010 bribelge Word 3 12-19-2012 09:25 AM


All times are GMT -7. The time now is 02:47 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2019 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft