Append Word docx files while keeping their format in VBA - 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.

Answer 1

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.