Consulting

Results 1 to 4 of 4

Thread: Merging Documents into a New Document

  1. #1

    Post Merging Documents into a New Document

    Quote Originally Posted by macropod View Post
    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.
    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.
    Last edited by macropod; 05-31-2019 at 08:40 PM. Reason: Split from old thread

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    Quote Originally Posted by macropod View Post
    To eliminate the blank page, after:
    Quote Originally Posted by macropod View Post
    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

    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
    

  4. #4
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •