Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 06-13-2020, 03:22 AM
Lumberjax Lumberjax is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 10 Combine Multiple Documents from Multiple Folders while also inserting title Office 2019
Novice
Combine Multiple Documents from Multiple Folders while also inserting title
 
Join Date: Jun 2020
Posts: 7
Lumberjax is on a distinguished road
Unhappy

Hello Guys,


I really need your help and I'm kind of desperate here.
I`m using Microsoft Office 365 Pro Plus and everything I've programmed so far is a tiny bit of java.
Anyways: I need a Makro via VBA, that combines multiple Documents.
The goal is to select a folder and combine all the word-documents in that folder and in the folders of that folder and so on.
It also has to put the title of each Document above its text and so on.
It needs to organise the combined files in the same structure as the folders are organised. It also has to put the foldernames in the correct order above the documents.
The documents may contain pictures, charts, headlines, etc.

If you guys have any questions feel free to ask.
Thank you guys in advance for any help.

P.S.: I've already been looking at this thread, but it doesnt go deep enough:
https://www.msofficeforums.com/word-...documents.html
Reply With Quote
  #2  
Old 06-13-2020, 04:21 PM
macropod's Avatar
macropod macropod is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 7 64bit Combine Multiple Documents from Multiple Folders while also inserting title Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Quote:
Originally Posted by Lumberjax View Post
I need a Makro via VBA, that combines multiple Documents.
The goal is to select a folder and combine all the word-documents in that folder and in the folders of that folder and so on.
It also has to put the title of each Document above its text and so on.
...
P.S.: I've already been looking at this thread, but it doesnt go deep enough:
https://www.msofficeforums.com/word-...documents.html
The code you linked to does almost all of what you asked for. To:
• insert the title, you need to say where 'above its text' means. For example, if it's in the header, where in the header, and what is supposed to happen with any existing content. Wherever you put it, it's likely to mess with the existing pagination.
• have it process multiple sub-folders, make the changes indicated in: https://www.msofficeforums.com/47785-post15.html
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #3  
Old 06-15-2020, 07:42 AM
Lumberjax Lumberjax is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 10 Combine Multiple Documents from Multiple Folders while also inserting title Office 2019
Novice
Combine Multiple Documents from Multiple Folders while also inserting title
 
Join Date: Jun 2020
Posts: 7
Lumberjax is on a distinguished road
Question

Quote:
Originally Posted by macropod View Post
The code you linked to does almost all of what you asked for. To:
• insert the title, you need to say where 'above its text' means. For example, if it's in the header, where in the header, and what is supposed to happen with any existing content. Wherever you put it, it's likely to mess with the existing pagination.
• have it process multiple sub-folders, make the changes indicated in: https://www.msofficeforums.com/47785-post15.html

Thanks for the reply.
If I insert these changes I get an error.
It says there was an error with compiling.
A Sub or a Function isn't defined.
And its marking Sub Main() in yellow.
I'll insert my code in here as well so you can see if I made a grave mistake or something.

Code:
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
I inserted the whole Code you send me, above the whole Code I already had.
Then I changed these two things:
Sub CombineDocuments()
to
Sub CombineDocuments(oFolder As String)
and
strFolder = GetFolder: If strFolder = "" Then Exit Sub
to
strFolder = oFolder
Reply With Quote
  #4  
Old 06-16-2020, 01:14 AM
macropod's Avatar
macropod macropod is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 7 64bit Combine Multiple Documents from Multiple Folders while also inserting title Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

If you checked the code line on which the error occurs, you'd see that:
Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
is highlighted.
Fairly obviously, I'd have thought, for consistency with the rest of the code you'd need to change that to:
Call CombineDocuments(CStr(Split(StrFolds, vbCr)(i)))
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #5  
Old 06-16-2020, 02:23 AM
Lumberjax Lumberjax is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 10 Combine Multiple Documents from Multiple Folders while also inserting title Office 2019
Novice
Combine Multiple Documents from Multiple Folders while also inserting title
 
Join Date: Jun 2020
Posts: 7
Lumberjax is on a distinguished road
Question

Quote:
Originally Posted by macropod View Post
If you checked the code line on which the error occurs, you'd see that:
Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
is highlighted.
Fairly obviously, I'd have thought, for consistency with the rest of the code you'd need to change that to:
Call CombineDocuments(CStr(Split(StrFolds, vbCr)(i)))
I did change that now and the error with compiling is gone, but theres a new error:
runtime error '4248'
this command isn't available, because no document is opened.

It happens when I try running the makro in one of the subfolders.
If I ask him to debug he's marking this in yellow:
Set wdDocTgt = ActiveDocument

(you'll find it close under Sub CombineDocuments)
He's still creating a Document, but it's empty.

If I run the makro on my topfolder it's getting a different error:
runtime error '5937'
the content can't be copied between these two areas

If I ask him to debug he's marking this in yellow:
.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText

(you'll find it in the middle of the Sub CombineDocuments)
What do I have to change?
Here's the changed code for you
Thanks fro the help again.

Code:
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
Reply With Quote
  #6  
Old 06-16-2020, 03:30 AM
macropod's Avatar
macropod macropod is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 7 64bit Combine Multiple Documents from Multiple Folders while also inserting title Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Try the following code. All you need do is select the top folder. Documents in the selected folder and all folders below it will be combined into the active document.
Code:
Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String
Dim wdDocTgt As Document, strTgt 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
Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName
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
wdDocTgt.Save
Set wdDocTgt = Nothing
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
Dim wdDocSrc As Document, HdFt As HeaderFooter
strFolder = oFolder
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
Set wdDocSrc = 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
PS: Please post formatted code. At the very least, you should preview your posts (e.g. by clicking 'Go Advanced') to ensure your code will be properly formatted - which really isn't difficult to do.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #7  
Old 06-16-2020, 03:47 AM
Lumberjax Lumberjax is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 10 Combine Multiple Documents from Multiple Folders while also inserting title Office 2019
Novice
Combine Multiple Documents from Multiple Folders while also inserting title
 
Join Date: Jun 2020
Posts: 7
Lumberjax is on a distinguished road
Default

So I did try out this code and on the first try it did process on my top folder,

but it only combined the first file in the subfolders with the open file.
On the next trys wich happened on the top folder and the subfolders it did nothing at all.
On about the forth try on the top folder it posted runtime error '5937' and now it's doing nothing again.
I tryed deleting the code again and pasting it in there again, but that didn't help.

P.S.: Sorry about the unformatted code. I don't know why it's doing that. In trhe preview it's always looking the way it should...
Reply With Quote
  #8  
Old 06-16-2020, 04:06 AM
macropod's Avatar
macropod macropod is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 7 64bit Combine Multiple Documents from Multiple Folders while also inserting title Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Quote:
Originally Posted by Lumberjax View Post
So I did try out this code and on the first try it did process on my top folder,

but it only combined the first file in the subfolders with the open file.
That part of the code is no different than it was originally and is specifically written to process all files in the top folder and sub-folders.
Quote:
Originally Posted by Lumberjax View Post
On the next trys wich happened on the top folder and the subfolders it did nothing at all
That suggests you didn't actually click OK after selecting the folder - or that you messed with the code.
Quote:
Originally Posted by Lumberjax View Post
On about the forth try on the top folder it posted runtime error '5937' and now it's doing nothing again.
I tryed deleting the code again and pasting it in there again, but that didn't help.
Perhaps you should try re-starting Word (or even re-starting Windows).

PS: Kindly don't quote previous posts in your reply unless there's something specific you need to refer to, in which case quote only that part. Anything more just adds clutter.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #9  
Old 06-16-2020, 07:00 AM
Lumberjax Lumberjax is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 10 Combine Multiple Documents from Multiple Folders while also inserting title Office 2019
Novice
Combine Multiple Documents from Multiple Folders while also inserting title
 
Join Date: Jun 2020
Posts: 7
Lumberjax is on a distinguished road
Unhappy

I did it again now.
I restarted my laptop, I copied and pasted the code in again.
But it's still ejecting a runtime error '5937'.
It's marking this again:
i.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText


Furthermore it's collecting all files from the first subfolder twice in the active document.
But it's collecting none from the files in the secong subfolder.
Reply With Quote
  #10  
Old 06-16-2020, 03:39 PM
macropod's Avatar
macropod macropod is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 7 64bit Combine Multiple Documents from Multiple Folders while also inserting title Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

The only reference anywhere to:
i.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText
is in your last post...
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #11  
Old 06-17-2020, 01:44 AM
Lumberjax Lumberjax is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 10 Combine Multiple Documents from Multiple Folders while also inserting title Office 2019
Novice
Combine Multiple Documents from Multiple Folders while also inserting title
 
Join Date: Jun 2020
Posts: 7
Lumberjax is on a distinguished road
Default

Quote:
Originally Posted by macropod View Post
The only reference anywhere to:
i.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText
is in your last post...

Do you mean you can't find it in the code by that?
Or to reprhrase. What do I have to do to make this work :/
Reply With Quote
  #12  
Old 06-17-2020, 05:41 AM
macropod's Avatar
macropod macropod is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 7 64bit Combine Multiple Documents from Multiple Folders while also inserting title Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

I mean there is no such line in any of the code previously discussed in this thread. Your insertion of 'i' before '.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText' has rendered that entire line invalid.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #13  
Old 06-17-2020, 06:20 AM
Lumberjax Lumberjax is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 10 Combine Multiple Documents from Multiple Folders while also inserting title Office 2019
Novice
Combine Multiple Documents from Multiple Folders while also inserting title
 
Join Date: Jun 2020
Posts: 7
Lumberjax is on a distinguished road
Default

I'm so sorry about that.
That was a Typo.
That 'i' isn't in my real code.
The Code is still having runtime error '5937'.
And it's adding empty pages to my active document.
How do I change that?
Reply With Quote
  #14  
Old 06-17-2020, 04:26 PM
macropod's Avatar
macropod macropod is offline Combine Multiple Documents from Multiple Folders while also inserting title Windows 7 64bit Combine Multiple Documents from Multiple Folders while also inserting title Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

The code -as posted - runs just fine for me, with no «runtime error '5937'». I've generated a combined document containing close to 300 pages with it.

As for the empty pages, that will be due to your source documents having such pages. The macro is coded to faithfully reproduce the source documents' content.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #15  
Old 03-07-2023, 07:12 AM
Alyb Alyb is offline Combine Multiple Documents from Multiple Folders while also inserting title Mac OS X Combine Multiple Documents from Multiple Folders while also inserting title Office 2016 for Mac
Novice
 
Join Date: Jan 2023
Posts: 4
Alyb is on a distinguished road
Default

Hello @macropod, your macro works fine on Word 365 for Windows (Microsoft® Word for Microsoft 365 MSO (Version 2302 Build 16.0.16130.20186) 32 bit
).

Of course it doesn't work on Word 365 for Mac version 16.70. This is probably because of the use of FSO.

Could you or some other kind person please change this macro so that it works on Mac too?

All documents to combine will be placed in the folder ToCombine on the Mac or Windows Desktop?

Thank you in advance!

PS Of course I have tried to modify your code myself but it was too complicated for me.
Reply With Quote
Reply

Tags
combine, help me, word vba

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Combine Multiple Documents from Multiple Folders while also inserting title Combine Multiple Word Documents macropod Word VBA 0 09-04-2019 12:09 AM
Combine Multiple Documents from Multiple Folders while also inserting title best approach to combine documents being created by multiple users jwalke123 Word 5 08-08-2015 03:27 PM
Cross-referencing in multiple documents that will combine to make one report razberri Word 1 01-20-2014 01:00 AM
combine multiple documents word starter 2010 bribelge Word 3 12-19-2012 09:25 AM
Combine Multiple Documents from Multiple Folders while also inserting title linking title across multiple documents Foxtrot75 Word 1 03-02-2012 03:31 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 01:36 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft