Macro to merge mulitple word doc into one word doc

[Jagdev]

Hi Experts

I am looking for a macro which will merge multiple word document placed in a folder into one document. I find the below code and it fits into my requirement. I need to amend the code to ask for the folder location instead of setting a default location to pick the word docs.

Please let me with the amendments.


Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String
Const strFolder = "P:\Doc files\New folder\New folder\" 'change to suit
Set MainDoc = Documents.Add
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
Set rng = MainDoc.Range
rng.Collapse wdCollapseEnd
rng.InsertFile strFolder & strFile
strFile = Dir$()
Loop
MsgBox ("Files are merged")

End Sub

[gmaxey]

Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Els
Exit Sub
End If
End With
Set MainDoc = Documents.Add
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
Set rng = MainDoc.Range
rng.Collapse wdCollapseEnd
rng.InsertFile strFolder & strFile
strFile = Dir$()
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub

[Jagdev]

Hi Greg

Thanks for the code. It really worked.

Sorry for troubling you little more. I find one discrepancy in my end result i.e. in most of the cases the document ends up in the next page, half section of the next page and the doc next to it starts from half way of that page. It looks messy. I think it is called page break. In case of manual intervention, we pull the new doc from the half page to the start of the next page. Is it possible to amend the code to do the same activity automatically?
Regards,
JD

[gmayor]

You should insert a next page section break e.g.



Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Set MainDoc = Documents.Add
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Count = 0
Do Until strFile = ""
Count = Count + 1
Set rng = MainDoc.Range
With rng
.Collapse wdCollapseEnd
If Count > 1 Then
.InsertBreak wdSectionBreakNextPage
.End = MainDoc.Range.End
.Collapse wdCollapseEnd
End If
.InsertFile strFolder & strFile
End With
strFile = Dir$()
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub


You may also be interested in http://www.gmayor.com/Boiler.htm which would give you more control over what you are collating.

[Jagdev]

Hi Graham
First of all, how are you?
I tried the above code in the macro, but the result is unchanged as in same result.
Also, I would like to inform you that I have table in all the word docs which needs to be merged.
I have a common word at the end of every doc file – “Contact details”. Could we set this as a criteria amd whenever this word is encountered the page should get break and the next doc should start from the new page.
Is that possible!
Regards,
JD

[gmayor]

I am doing OK - I have another medical appointment next week when I may know more.

The modified macro I posted should insert each separate document starting on a new page. It certainly does here. Is that not happening for you? The table should not affect the results, and searching for a text string is less efficient than selecting the end of the document.

Did you replace Greg's code with the revised version?

[Jagdev]

Hi Graham

I wish everything should be fine with the reports.

I did replaced the code.

Unfortunately, the documents are getting merged and reflecting one after the other without Page break.

Regards,
JD

[gmayor]

Hmmm. Click the ¶ button on the home tab of the ribbon (or CTRL+Shift 8) and see if the section breaks have been inserted. I can't immediately see why the code I posted doesn't work.

[Jagdev]

Hi Graham

I did that and the result is same. Please see the screen-shot the Section break(Continuous) is appearing in the same page. I am not sure if this is what you meant.
:banghead:
Regards,
JD

[gmayor]

If those breaks were not in the original documents, it would seem that for some reason the code is inserting continuous section breaks rather than next page section breaks as instructed. If they were in the original documents, then

Change

wdSectionBreakNextPage

to


wdPageBreak

[Jagdev]

Hi Graham

You are a Champ!

This is perfect.

Regards,
JD

[gmayor]

I still can't for the life of me understand why the original didn't work for you. Which Word version are you using?

[Jagdev]

Hi Graham

I am using word 2010.

Regards,
JD

[gmayor]

Same here :(

[Jagdev]

Hi Graham

Strange!

Sorry for troubling you little more. Say after running the above macro I will get different word docs into one file. On the contrast if I need to split the same merged file back to individual files..Is that possible.

Regards,
JD

[gmayor]

There is some code at http://www.gmayor.com/individual_merge_letters.htm that will help with that.

[Jagdev]

Hi Graham

There are so many codes available in the above link. Could you please let me know with which code should I go with.

Regards,
JD

[gmayor]

None of them will work without modification unless you resolve the issue of why your PC is not creating the section breaks from the first code. I can't see any valid reason why it should create a page break but not a next page section break. Resolve that and you can use the 'Splitter' macro, which I think is the first listed code.

[Jagdev]

Hi Graham
I tried the code again but same result. Is there anything wrong with my Word doc setting? Please let me know if that is the case. I tried all the permutation and combination from my end to find the root cause.
Regards,
JD

[gmayor]

There is no reason why the following should perform any differently, but I would be interested to see if it does.


Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Set MainDoc = Documents.Add
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Count = 0
Do Until strFile = ""
Count = Count + 1
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 1 Then
.InsertBreak 2
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
strFile = Dir$()
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub


If not, reboot the PC. Word 2010 will store up errors and the only way I have found to clear them is to reboot. Ensure there are no orphan lock files - see http://www.gmayor.com/what_to_do_when_word_crashes.htm (http://www.gmayor.com/what_to_do_when_word_crashes.htm)

Temporarily rename the normal template. If you have not changed the default location enter or copy
%appdata%\Microsoft\Templates
to the address window of Windows Explorer and you will be taken to the folder that contains the default template - which for Word 2010 is normal.dotm. Note that this folder is normally hidden.

Restart Word and see if the above macro works. If it does, close Word, restore your old normal template and try it again.

[Jagdev]

Hi Graham

I did all the above changes and tried to run the macro, but the result is the same the old one.

Regards,
JD

[kdauria]

The code works awesomely. But the docs are not laid out exactly as the originals in the new file.
Is there something I can insert into the code to retain each document's format when it's being compiled?

[gmayor]

No - that's as good as it gets. Combining disparate document formats will always be a compromise.

[kdauria]

No - that's as good as it gets. Combining disparate document formats will always be a compromise.


That is terribly heartbreaking.

[illogic]

Hello everyone,

i am using the code from gmayor to merge multiple documents into a single document.



Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Set MainDoc = Documents.Add
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Count = 0
Do Until strFile = ""
Count = Count + 1
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 1 Then
.InsertBreak 2
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
strFile = Dir$()
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub






It is doing what it is supposed to do, but i am having a specific problem with the merged document.
The formating of the original documents isn't translated into the new document that gets created by the macro.
Normaly the original document is one page in size. In the new document, a part of the bottom is put onto a second page.
i think it has something to do with margins.

Is there a way to keep the page layout/margins from the original document and transfer that to the new document ?

greetings

Manuel

[gmayor]

The code in question creates the base document using the normal template
Set MainDoc = Documents.AddYou would need to use the first document as a template to ensure you have its margins - e.g. as follows. Better still use http://www.gmayor.com/Boiler.htm


Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Count = 0
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
If Count = 0 Then
Set MainDoc = Documents.Add(Template:=strFolder & strFile)
Count = Count + 1
Else
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 1 Then
.InsertBreak 2
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
End If
strFile = Dir$()
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub

[illogic]

The code in question creates the base document using the normal template
Set MainDoc = Documents.AddYou would need to use the first document as a template to ensure you have its margins - e.g. as follows. Better still use http://www.gmayor.com/Boiler.htm


Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Count = 0
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
If Count = 0 Then
Set MainDoc = Documents.Add(Template:=strFolder & strFile)
Count = Count + 1
Else
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 1 Then
.InsertBreak 2
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
End If
strFile = Dir$()
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub



Thanks for the reply,

when i execute the code above, i get a runtime error "4605" and ".InsertFile strFolder & strFile" gets marked.


I also tried to use your ´recomended Boiler Add-In but it seems that it only recognizes normal documents.
The documents that i need to merge are mostly docm files with macros.
Is there any chance that it still works with macro enabled documents?

[gmayor]

Hmmm. The only thing I can think of is a problem relating to the macros you say are in the document(s). The following should address (and has been tested in Word 2010 and 2016) that:

Option Explicit

Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Count = 0
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
WordBasic.DisableAutoMacros 1
If Count = 0 Then
Set MainDoc = Documents.Add(Template:=strFolder & strFile)
Count = Count + 1
Else
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 1 Then
.InsertBreak 2
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
End If
strFile = Dir$()
WordBasic.DisableAutoMacros 0
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub


The latest version 3.4 of the Boiler add-in does work with DOCM files. When using the add-in, start with the file on screen that has the format you wish to merge into. The macros in the inserted documents will not run.

[illogic]

Hi there,

i tried your modified code but it gives me an error saying that the documents are protected.
I thought this code would work somewhat like the build in 'text from file' comand in the 'object menu' on the 'insert tab', where it is not necessary to remove the doccuments protection.
I was looking for a more automated approach because this comand is only capable of merging a couple of documents at a time. I think the limit is 25 docs.
When you need to merge 300+ Documents it becomes very tedious for the user.
Is there a way to work around that problem, making the code usable without removing the protection of each document?

Regarding the Boiler Add-In:
When i use the Boiler Add-In, in the file selection window, only 'docx' documents are recognized.
The 'docm' files won't show up. I have version 3.4 installed.
Any clues why these files aren't recognized by the add-in?

I am sorry to take so much of your time. I hoped that it would be less complicated.

[gmayor]

Version 3.4 of Boiler certainly lists docm format files


17134
The documents are protected? Protected how?

[illogic]

Ok, i deinstalled the boiler Add-In and reinstalled it.
It seems that there previously was a version 3.3 installed.
Now the Add-In lists all the documents, but it is running into the same problem as the other code.

Run-time error '4605':
This method or property is not available because the object refers to a protected area of the document.

All docm files are protected with restricted editing. so that it is only allowed to fill in forms.

Using the build in 'text from file' command is not having any problems with this restriction.

[Immanuel]

Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Count = 0
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
If Count = 0 Then
Set MainDoc = Documents.Add(Template:=strFolder & strFile)
Count = Count + 1
Else
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 1 Then
.InsertBreak 2
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
End If
strFile = Dir$()
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub

[/QUOTE]

this code perfectly retains the source format but again the line break doesn't work, ending up in combining the new document in previous document; tried replacing the .InsertBreak wdSectionBreakNextPage but it really dint make any change. Will appreciate your help.

[Kilroy]

Minor change. Works for me


Option Explicit

Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Count = 0
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
WordBasic.DisableAutoMacros 1
If Count = 0 Then
Set MainDoc = Documents.Add(Template:=strFolder & strFile)
Count = Count + 1
Else
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 0 Then
.InsertBreak Type:=wdSectionBreakNextPage
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
End If
strFile = Dir$()
WordBasic.DisableAutoMacros 0
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub

[macropod]

No - that's as good as it gets. Combining disparate document formats will always be a compromise.
Merging multiple documents is often rather more complex than simply copying & pasting content from one document to another. Problems arise when the documents have different page layouts, headers, footers, page numbering, bookmarks & cross-references, Tables of Contents, Indexes, etc., etc., and especially when those documents have used the same Style names with different definitions. The compromises can be mitigated, though.

The following macro handles the more common issues that arise when merging documents; it does not attempt to resolve page numbering, Tables of Contents or Indexes. Neither does it attempt to deal with the effects on footnote or endnote numbering & positioning or with the consequences of duplicated bookmarks (only one of which can exist in the merged document) and any corresponding cross-references.

The macro includes a folder browser. Simply select the folder to process and all documents from that folder will be merged into the active document.

Sub MergeDocuments()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Dim strFolder As String, strFile As String
Dim DocSrc As Document, DocTgt As Document
Dim strDocNm As String, Rng As Range, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set DocTgt = ActiveDocument
strDocNm = DocTgt.FullName
strFile = Dir(strFolder & "\*.doc")
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set DocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With DocTgt
Set Rng = .Range.Characters.Last
With Rng
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse wdCollapseEnd
Call LayoutTransfer(DocSrc, DocTgt)
.FormattedText = DocSrc.Range.FormattedText
End With
For Each HdFt In .Sections.Last.Headers
HdFt.LinkToPrevious = False
HdFt.Range.Text = vbNullString
Next
For Each HdFt In .Sections.Last.Footers
HdFt.LinkToPrevious = False
HdFt.Range.Text = vbNullString
Next
For Each HdFt In .Sections(.Sections.Count - 1).Headers
With HdFt.Range
.FormattedText = DocSrc.Sections.Last.Headers(HdFt.Index).Range.FormattedText
.Characters.Last.Delete
End With
Next
For Each HdFt In .Sections(.Sections.Count - 1).Footers
With HdFt.Range
.FormattedText = DocSrc.Sections.Last. Footers(HdFt.Index).Range.FormattedText
.Characters.Last.Delete
End With
Next
End With
DocSrc.Close False
End If
strFile = Dir()
Wend
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True
End Sub
Sub LayoutTransfer(DocSrc As Document, DocTgt As Document)
'Document Body variables
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 bOrientation As Boolean
'Get Page Setup parameters
With DocSrc.Sections.First.PageSetup
lPaperSize = .PaperSize
lGutterStyle = .GutterStyle
bOrientation = .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
'Set Page Setup parameters
With DocTgt.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 = bOrientation
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

[Immanuel]

Minor change. Works for me


Option Explicit

Sub MergeDocs()
Dim rng As Range
Dim MainDoc As Document
Dim strFile As String, strFolder As String
Dim Count As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Pick folder"
.AllowMultiSelect = False
If .Show Then
strFolder = .SelectedItems(1) & Application.PathSeparator
Else
Exit Sub
End If
End With
Count = 0
strFile = Dir$(strFolder & "*.doc") ' can change to .docx
Do Until strFile = ""
WordBasic.DisableAutoMacros 1
If Count = 0 Then
Set MainDoc = Documents.Add(Template:=strFolder & strFile)
Count = Count + 1
Else
Set rng = MainDoc.Range
With rng
.Collapse 0
If Count > 0 Then
.InsertBreak Type:=wdSectionBreakNextPage
.End = MainDoc.Range.End
.Collapse 0
End If
.InsertFile strFolder & strFile
End With
End If
strFile = Dir$()
WordBasic.DisableAutoMacros 0
Loop
MsgBox ("Files are merged")
lbl_Exit:
Exit Sub
End Sub




was Perfect, Thank you.

[Kilroy]

No problem I just fiddled around with code written by the experts Greg, Graham & Paul. Thanks guys very useful macro.

[tomaszko]

Is there any way to merge documents that are attached (add obcject) to the word document?

[macropod]

Is there any way to merge documents that are attached (add obcject) to the word document?
Given that the topic of this thread is all about merging multiple documents into one, perhaps you could clarify what you want that isn't already covered?

[tomaszko]

Given that the topic of this thread is all about merging multiple documents into one, perhaps you could clarify what you want that isn't already covered?

What's my plan about how to choose files...

I have a form in Word document (.docm) from which I would like to choose which files (checking tick boxes) to merge those choosed files together while keeping text formating, numbering etc.

So I would like to link tick boxes to specific file then when te tick box are choosen only those choosed files will be merged.

From the code above you can only choose folder from whoom all files will be merged together, and my need is to go step further.

Is this make any sense?

Thanks.

[macropod]

In that case, start a thread that deals with what you want to do instead of hijacking a thread about something completely different.