Merging Documents into a New Document

Quote:

---

Originally Posted by macropod

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.

Code:

---

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/show...o-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.

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.

Quote:

---

Originally Posted by macropod

To eliminate the blank page, after:

---

Quote:

---

Originally Posted by macropod

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

Code:

---

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


---

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.