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 CombineDocuments(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