Dim FSO As Object, oFolder As Object, StrFolds As String

Sub Main()
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
StrFolds = vbCr & TopLevelFolder
If TopLevelFolder = "" Then Exit Sub
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject") 
End If 
'Get the sub-folder structure 
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders 
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder) 
Next 
'Process the documents in each folder 
For i = 1 To UBound(Split(StrFolds, vbCr)) 
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i))) 
Next 
End Sub

Sub RecurseWriteFolderName(aFolder) 
Dim SubFolders As Variant, SubFolder As Variant 
Set SubFolders = FSO.GetFolder(aFolder).SubFolders 
StrFolds = StrFolds & vbCr & CStr(aFolder) 
On Error Resume Next 
For Each SubFolder In SubFolders 
  RecurseWriteFolderName (SubFolder) 
Next 
End Sub

Sub CombineDocuments(oFolder As String)
Application.ScreenUpdating = False 
Dim strFolder As String, strFile As String, strTgt As String 
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter 
strFolder = oFolder 
Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName 
strFile = Dir(strFolder & "\*.doc", 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 
            .PageNumbers.RestartNumberingAtSection = True 
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber 
          End With 
        Next 
        For Each HdFt In .Footers 
          With HdFt 
            .LinkToPrevious = False 
            .Range.Text = vbNullString 
            .PageNumbers.RestartNumberingAtSection = True 
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber 
          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