Append Word docx files while keeping their format in VBA

Question

I am creating a Word Macro that receives two arguments: a list of docx documents and the name of the new file. The goal is that the Macro inserts one document after the other, preserving their respective format, and saves as a new docx document.

Sub Merger(path As String, args () As Variant)
        Dim vArg As Variant
     
        Active Document.Select
        Selection.ClearFormatting

        For Each vArg In args
          ActiveDocument.Content.Words.Last.Select
          Selection.InsertFile:= _ vArg _,Range:="", _ConfirmConversions:= False, Link:=False, Attachment:= False )
          Selection.InsertBreak Type:=wdPageBreak
        Next vArg
      
        ActiveDocument.SaveAs2 File Name=path
        ActiveDocument.Close
        Application.Quit

Note that I call the Macro from an empty docx file.

The problem is that neither the header nor the format of the orginal files are preserved in the new docx document.

Word's datamodel does not support this. Within a document styles and header / footers are shared entities. — Boeryepes
Before you attempt to write code perform the operation manually. If you find a method of achieving what you want through the Word UI you can then proceed to automate it in code. — Timothy Rylatt
I have managed to improve de VBA code and, now, the new document preserves de header and the footers. The problemas continuous to be the style... — MufasaComp

John Korchok John Korchok · Accepted Answer · 2020-08-03T21:39:43

The Word format is not modular. Instead, consider creating a Master Document, then filling it with subdocuments. Here's code to create a master document from a folder full of subdocuments:

Sub AssembleMasterDoc()
  Dim SubDocFile$, FolderPath$, Template$
  Dim Counter&
  Dim oFolder As FileDialog
  Dim oBookmark As Bookmark
  Dim oTOC As TableOfContents
'Create a dynamic array variable, and then declare its initial size
  Dim DirectoryListArray() As String
  ReDim DirectoryListArray(1000)
  Template$ = ActiveDocument.AttachedTemplate.Path & Application.PathSeparator & ActiveDocument.AttachedTemplate.Name
'Loop through all the files in the directory by using Dir$ function
  Set oFolder = Application.FileDialog(msoFileDialogFolderPicker)
  With oFolder
    .AllowMultiSelect = False
    If .Show <> 0 Then
      FolderPath$ = .SelectedItems(1)
    Else
      GoTo EndSub
    End If
  End With
  Application.ScreenUpdating = False
  SubDocFile$ = Dir$(FolderPath$ & Application.PathSeparator & "*.*")
  Do While SubDocFile$ <> ""
      DirectoryListArray(Counter) = SubDocFile$
      SubDocFile$ = Dir$
      Counter& = Counter& + 1
  Loop

'Reset the size of the array without losing its values by using Redim Preserve
  ReDim Preserve DirectoryListArray(Counter& - 1)
  WordBasic.SortArray DirectoryListArray()
  ActiveWindow.ActivePane.View.Type = wdOutlineView
  ActiveWindow.View = wdMasterView
  Selection.EndKey Unit:=wdStory
  For x = 0 To (Counter& - 1)
    If IsNumeric(Left(DirectoryListArray(x), 1)) Then
      FullName$ = FolderPath$ & Application.PathSeparator & DirectoryListArray(x)
      Documents.Open FileName:=FullName$, ConfirmConversions:=False
      With Documents(FullName$)
        .AttachedTemplate = Template$
        For Each oBookmark In Documents(FullName$).Bookmarks
          oBookmark.Delete
        Next oBookmark
        .Close SaveChanges:=True
      End With
      Selection.Range.Subdocuments.AddFromFile Name:=FullName$, ConfirmConversions:=False
    End If
  Next x
  For Each oTOC In ActiveDocument.TablesOfContents
    oTOC.Update
  Next oTOC
  ActiveWindow.ActivePane.View.Type = wdPrintView
  Application.ScreenUpdating = True
EndSub:
End Sub

This code is from a previous project, so you may not need all of it, like the update of multiple TOCs.

Don't attempt to maintain and edit Master Documents. The format is prone to corruption. Instead, assemble a master document for printing (or other use), then discard it.

Append Word docx files while keeping their format in VBA

1 Answers