VBA-Excel – Merger – Merge or Combine Many Word Documents Into One
If you want to combine or merger many word document into one file and you don’t want to do it manually, This piece of software will allow you merge as many word document you want, say 500-1000 word documents. This tool will provide you to option to select ot de-select word documents before merging.
How to Use it:
- Download the WordMerger.xlsm from the link provided at the top and at the bottom of this article.
- Place all the Word documents, which you want to combine, into one folder (make sure all files are closed).
3. Open the WordMerger.xlsm.
4. Put the “Folder path” Example : “ C:\Users\Sumit Jain\Desktop\Word Docs”
5. Put destination path for Merged Files : “ C:\Users\Sumit Jain\Desktop\”
6. Click on Fetch Files . This will fetch files from the Folder and will display.
7. Select or de-select files.
8. Click on Merge
9. Files will be mergred and saved at the given location.
'Dim fso As New FileSystemObject Dim NoOfFiles As Double Dim counter As Integer Dim r_counter As Integer Dim s As String Dim listfiles As Files Dim newfile As Worksheet Dim mainworkbook As Workbook Dim FetchFileClicked Dim Folderpath As Variant Sub Sumit() If FetchFileClicked = False Then MsgBox "First click the 'Fetch Files' button" End End If Application.ScreenUpdating = False strRandom = Replace(Replace(Replace(Now, ":", ""), "/", ""), " ", "") MergeFileName = "Merger" & strRandom & ".doc" MergeFolder = mainworkbook.Sheets("Main").Range("L10").Value Set objWord = CreateObject("Word.Application") Set objDoc = objWord.Documents.Add objWord.Visible = True Set objSelection = objWord.Selection objDoc.SaveAs (MergeFolder & MergeFileName) For i = 1 To NoOfFiles If Range("B" & i).Value = "Yes" Then Set objTempWord = CreateObject("Word.Application") Set tempDoc = objWord.Documents.Open(Folderpath & "\" & Range("A" & i).Value) Set objTempSelection = objTempWord.Selection tempDoc.Range.Select tempDoc.Range.Copy objSelection.TypeParagraph objSelection.Paste tempDoc.Close End If Next objDoc.Save Application.ScreenUpdating = True mainworkbook.Sheets("Main").Activate MsgBox "Completed...Merge File is saved at " & MergeFolder & MergeFileName FetchFileClicked = False End Sub Sub fetchFiles() Set mainworkbook = ActiveWorkbook Range("A:A").Clear Range("B:B").Clear Folderpath = mainworkbook.Sheets("Main").Range("L8").Value Set fso = CreateObject("Scripting.FileSystemObject") NoOfFiles = fso.GetFolder(Folderpath).Files.Count Set listfiles = fso.GetFolder(Folderpath).Files counter = 0 For Each fls In listfiles counter = counter + 1 Range("A" & counter).Value = fls.Name Range("B" & counter).Value = "Yes" Range("A" & counter).Borders.Value = 1 Range("B" & counter).Borders.Value = 1 With Range("B" & counter).Validation .Delete 'replace "=A1:A6" with the range the data is in. .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:="Yes,No" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With Next MsgBox "Files are Fetched,Please select the files to be merged" FetchFileClicked = True End Sub