#1
|
||||
|
||||
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 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 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 Code:
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter, Fld As Field Code:
For Each Fld In .Range.Fields If Fld.Type = wdFieldNumPages Then Fld.Code.Text = Replace(Fld.Code.Text, "NUMPAGES", "SECTIONPAGES") Next Code:
.Range.Characters.Last.Delete
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
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 |
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 |