VBA to Combine Differently Formatted Word Files into 1 while Preserving Layouts

[agent_maxine]

Dear Mr. Excel,

Would like to request your kind assistance on my codes below... I have codes that will allow me to select multiple files and combine them into 1 Word (then exports into 1 PDF). Problem is:

• Headers/Footers: The header/footer from the first file is used for the entire combined file.
• Font Types/Sizes/Layouts: It seems to use the Word default template's font type/sizes and disregards the types used in original Word documents (even the first file).

How can I make it so that the Combined File keeps the formatting of individual documents? Codes were adopted from this page:
https://www.datanumen.com/blogs/2-ways-quickly-merge-multiple-word-documents-one-via-vba/

Sub Combine_Selected_Documents()

Dim dlgFile As FileDialog
Dim nTotalFiles As Integer, nEachSelectedFile As Integer
Dim strFolder As String, myFolder As folder

Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")

Set dlgFile = Application.FileDialog(msoFileDialogFilePicker)

With dlgFile
    .AllowMultiSelect = True
    If .Show <> -1 Then
        Exit Sub
    Else
        strFolder = .SelectedItems(1) & Application.PathSeparator
        nTotalFiles = .SelectedItems.Count
    End If
End With

'Add code to check if PDF file exists, if no Word files were selected, if it works with different Word Document names, etc.

Dim myArr
myArr = Split(strFolder, "\")
strFolder = myArr(0)
For i = 1 To UBound(myArr) - 2
    strFolder = strFolder & "\" & myArr(i)
Next i
strFolder = strFolder & "\"
'MsgBox strFolder

Dim objWord As Word.Application
Set objWord = CreateObject("Word.Application")
Dim objDoc As Word.Document
Set objDoc = objWord.Documents.Add
objWord.Visible = False 'Temporary
Set objSelection = objWord.Selection
'objSelection.TypeText ("This is my text in Word Document using Excel")

For nEachSelectedFile = 1 To nTotalFiles
objSelection.InsertFile dlgFile.SelectedItems.Item(nEachSelectedFile)
   
    If nEachSelectedFile < nTotalFiles Then
        objSelection.InsertBreak Type:=wdSectionBreakNextPage
        
    Else
        If nEachSelectedFile = nTotalFiles Then
        objDoc.ExportAsFixedFormat OutputFileName:=strFolder & "Forms.pdf", ExportFormat:=wdExportFormatPDF ', OpenafterPublish:=OpenafterPublish
        objDoc.SaveAs2 (strFolder & "Forms Combined.docx")
        objDoc.Close
        'objWord.Quit
        
        Exit Sub
        End If
    End If
Next nEachSelectedFile

MsgBox "All the Selected Documents have been Combined into 1 PDF File."

End Sub

 

[Macropod]

The code to do that is rather more complex than what you presently have. Not only do you need to transfer the body content of all the source documents to a new file before doing the PDF conversions, but you also need to transfer the page layouts and header/footer structure. Try the following:

Sub MergeDocuments()
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

 

[agent_maxine]

Hi Paul,

Yes I did actually try your codes before (found it on VBA Express I believe). It seems to use an Active Document though, and I didn't know how to tweak it so that it doesn't rely on having a document open.
How can the codes be adopted so that it works when no Word files are open?

Thank you!

 

[Macropod]

To combine documents, you must have a document they can be combined in. Since, if you're running the code from Word, you must also have a document open to run the macro, it seems to make sense for that to be the starting document.

 

[agent_maxine]

Sorry, should have clarified -- I am running the macro from Excel, not Word...

*Edit: I am hoping to run the codes from an Excel system that decides which files should be generated (done via separate set of codes). I am now working on piece where the files generated from the previous step are now combined into 1 Word (then to 1 PDF).

 

[Macropod]

In that case, try something along the lines of:

Sub MergeDocuments()
'Note: This code required a reference to Word, via Tools|References in the VBE.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strTgt As String
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application: wdApp.Visible = True
Dim wdDocTgt As Word.Document, wdDocSrc As Word.Document, HdFt As Word.HeaderFooter
Set wdDocTgt = wdApp.Documents.Add
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDocSrc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDocTgt
    If Len(.Range.Text) > 1 Then
      .Characters.Last.InsertBefore vbCr
      .Characters.Last.InsertBreak (wdSectionBreakNextPage)
    End If
    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
  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
wdApp.Quit
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing: Set wdApp= Nothing
Application.ScreenUpdating = True
End Sub

Sub LayoutTransfer(wdDocTgt As Word.Document, wdDocSrc As Word.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

As for your last post's edit, that means modifying the code further, so it only processes the designated files - presumably without the need for a folder/file selector, too.

 

[agent_maxine]

I'm getting the following error on this line (Line 12 from the Top).

Run-Time Error '438': Object doesn't support this property or method.

If Len(.Text) > 1 Then

Quick Note: I switched the order slightly after seeing the "Duplicate Declaration in Current Scope" message

Dim wdApp As New Word.Application, wdDocTgt As Word.Document, wdDocSrc As Word.Document, HdFt As Word.HeaderFooter
Set wdDocTgt = wdApp.Documents.Add

 

[Macropod]

I'm getting the following error on this line (Line 12 from the Top).

Run-Time Error '438': Object doesn't support this property or method.

If Len(.Text) > 1 Then

Oops, change that to:

If Len(.Range.Text) > 1 Then

Original code corrected.

 

[agent_maxine]

Hmm now I'm getting this...

Run-Time Error '4218': Type Mismatch.

.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText

 

[Macropod]

I've re-tested the code and I'm not getting that error. I suggest you:
1. Close Excel and Word
2. Use the Task Manager to kill any orphaned Excel/Word sessions
3. Re-start Excel & open your workbook
4. Replace the existing code with the updated code in post 6 (Note: I've added wdApp.Visible = True so you shouldn't get an orphaned Word session if a crash occurs)
5. Re-run the code.