VBA-Excel - Merger - Merge or Combine Many Word Documents Into One

Download Link:WordMerger

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).

Word Merger -1

3. Open the WordMerger.xlsm.

Word Merger -2

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.

Fetch Button

7. Select or de-select files.

Select Files

8. Click on Merge

Merge Button

9. Files will be mergred and saved at the given location.

Merged File

Complete Code:

    '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

Download Link:WordMerger

excel-macro-vba 58 microsoft word 24 tools and games 9