Compare word documents with Excel VBA and create a summary files with track changes

amadese57

New Member
Joined
Apr 8, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi,

I'm trying to create a vba script for an excel document in order to compage files versions and create summary Word documents with the differences (track changes).

Here my script:

VBA Code:
Private Sub ButtonSummaryReport_Click()
'Initialize the progressbar and the label
Dim k As Integer
Dim filesNumber As Integer

Dim i As Integer
Dim j As Integer
Dim objFolderAPath As String
Dim objFolderBPath As String
Dim objFolderCPath As String

Dim FileName As String
Dim WDApp As Object 'Word.Application
Dim WDDocA As Object 'Word.Document
Dim WDDocB As Object 'Word.Document
Dim WDDocC As Object 'Word.Document

Dim colFilesA As Object
Dim objFileA As Object

Dim wordapp

k = 0
Me.LabelSummaryReport.Caption = "Please wait..."
Me.ProgressBarSummaryReport.Value = k

'Create an instance of the FileSystemObject
Set objFSOA = CreateObject("Scripting.FileSystemObject")
Set objFSOB = CreateObject("Scripting.FileSystemObject")
Set objFSOC = CreateObject("Scripting.FileSystemObject")

'Select the path for the 3 folders
Set objFolderA = objFSOA.GetFolder(ChooseFolder("Choose the folder with the initial documents"))
objFolderAPath = objFolderA.Path
Debug.Print objFolderAPath

Set objFolderB = objFSOB.GetFolder(ChooseFolder("Choose the folder with revised documents"))
objFolderBPath = objFolderB.Path
Debug.Print objFolderBPath

Set objFolderC = objFSOC.GetFolder(ChooseFolder("Choose the folder for the comparisons documents"))
objFolderCPath = objFolderC.Path
Debug.Print objFolderCPath

Set colFilesA = CreateObject("Scripting.FileSystemObject")
Set objFileA = CreateObject("Scripting.FileSystemObject")

Set colFilesA = objFolderA.Files

'Turn off DisplayAlerts
Application.DisplayAlerts = wdAlertsNone

'Number of files in the folder
filesNumber = objFolderA.Files.Count

Me.LabelSummaryReport.Caption = "The comparison process starts..."
For Each objFileA In colFilesA

PathFileA = objFolderA.Path & "\" & objFileA.Name
PathFileB = objFolderB.Path & "\" & objFileA.Name
PathFileC = objFolderC.Path & "\" & objFileA.Name

If objFileA.Name Like "*.docx" Then

'Creating object of the word application
Set WDApp = CreateObject("word.Application")

'Making visible the word application
WDApp.Visible = True

'Opening the required word document
Set WDDocA = WDApp.Documents.Open(PathFileA)

'Opening the required word document
Set WDDocB = WDApp.Documents.Open(PathFileB)

' Create the Summary file with the track changes
WDApp.CompareDocuments _
OriginalDocument:=WDDocA, _
RevisedDocument:=WDDocB, _
Destination:=wdCompareDestinationNew, _
IgnoreAllComparisonWarnings:=True

'Close the documents to compare
WDDocA.Close
WDDocB.Close

'Turn off DisplayAlerts
Application.DisplayAlerts = wdAlertsNone

' Save the new summary file with track changes
Set WDDocC = ActiveDocument
WDDocC.SaveAs FileName:=PathFileC
WDDocC.Close SaveChanges:=True
End If

'Update of the progressbar and the label
k = k + 1
Me.LabelSummaryReport.Caption = k * 100 / filesNumber & "% Completed"
Me.ProgressBarSummaryReport.Value = k * 100 / filesNumber

Next objFileA
Me.LabelSummaryReport.Caption = "The process is complete. Comparison reports have been created."
End Sub

'Function used for choosing the folder where the files are located
Function ChooseFolder(title) As String
    Dim fldr As FileDialog
    Dim sItem As String

    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .title = title
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    ChooseFolder = sItem
    Set fldr = Nothing
End Function

I have an issue when I would like to save the summary document with the tranck changes and I don't know how to solve that (the document is not saved).

Could you please help me with that, and tell me please if my code is correct and optimized.

Thanks in advance
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

Dan_W

Active Member
Joined
Jul 11, 2018
Messages
485
Office Version
  1. 365
Platform
  1. Windows
Hi. You should go through the lines in your code step-by-step and debug them, because I think the logic in parts of the code might be causing bugs.

In any event, I can't be sure, but I wonder if it would help if you specified exactly which document is the one you want to save. At present, you're telling VBA to select which document happens to be the one left after having closed the original and revised versions. That may well be the case, but it's best to be more specific. I'd recommend changing this line:

WDApp.CompareDocuments OriginalDocument:=WDDocA, RevisedDocument:=WDDocB, Destination:=wdCompareDestinationNew, IgnoreAllComparisonWarnings:=True

to

Set WDDocC = WDApp.CompareDocuments(OriginalDocument:=WDDocA, RevisedDocument:=WDDocB, Destination:=wdCompareDestinationNew, IgnoreAllComparisonWarnings:=True)

and then deleting this line:

Set WDDocC = ActiveDocument

See if that improves things for you.
 

amadese57

New Member
Joined
Apr 8, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi,

Thanks for your reply. I applied the updates. But when I launch the go through the lines in your code step-by-step and debug them, I can see that when the system try to close WDDocA:

VBA Code:
WDDocA.Close

the summary file is also closed. And when the line for saving WDDocC:
VBA Code:
WDDocC.SaveAs FileName:=PathFileC

The following error appears:

Automation error
The object invoked has disconnected from its clients.

Could you help me please ?

Thanks in advance
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,791
Hi amadese57. You are creating multiple Word applications within your loop. You only need one. You also only need one file scripting object and you should always set all object variables to nothing before exiting a sub. Trial creating the Word application outside of the loop, set WdDocC as DanW advised and then save it before closing the other documents. The extra office objects won't matter. HTH. Dave
 

amadese57

New Member
Joined
Apr 8, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I changed my code and now it's working perfectly:

VBA Code:
Private Sub ButtonSummaryReport_Click()
    
    'Declare variable
    Dim k As Integer
    Dim filesNumber As Integer
    
    Dim i As Integer
    Dim j As Integer
    Dim objFolderAPath As String
    Dim objFolderBPath As String
    Dim objFolderCPath As String
    
    Dim FileName As String
    Dim wdApp As Word.Application
    Dim WDDocA As Word.Document
    Dim WDDocB As Word.Document
    Dim WDDocC As Word.Document
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolderA As Object
    Dim objFolderB As Object
    Dim objFolderC As Object
    Dim wordapp As Object
    Dim colFilesA As Object
    Dim objFileA As Object
    Dim PathFileA As String
    Dim PathFileB As String
    Dim PathFileC As String
      
    'Initialize the labels
    k = 0
    Me.LabelSummaryReport.Caption = "Please wait..."
    Me.LabelSummaryReportProgress = ""
 
    'Waiting for the refresh of the labels
    DoEvents
    DoEvents
    Application.Wait Now + #12:00:03 AM#
    
    'Create an instance of the FileSystemObject
    Set objFSO = New Scripting.FileSystemObject
    Set wordapp = New Word.Application
    
    'Select the path for the 3 folders
    Set objFolderA = objFSO.GetFolder(ChooseFolder("Choose the folder with the original documents"))
    objFolderAPath = objFolderA.Path
    
    Set objFolderB = objFSO.GetFolder(ChooseFolder("Choose the folder with revised documents"))
    objFolderBPath = objFolderB.Path
    
    Set objFolderC = objFSO.GetFolder(ChooseFolder("Choose the folder for the comparisons documents"))
    objFolderCPath = objFolderC.Path

    Set colFilesA = New Scripting.FileSystemObject
    Set objFileA = New Scripting.FileSystemObject
    
    Set colFilesA = objFolderA.Files
    
    'Turn off DisplayAlerts
    wordapp.DisplayAlerts = wdAlertsNone
 
    'Number of files in the folder
    filesNumber = objFolderA.Files.Count
      
    Me.LabelSummaryReport.Caption = "The comparison process starts..."
    For Each objFileA In colFilesA

    'Waiting for the refresh of the labels
    DoEvents
    DoEvents
    Application.Wait Now + #12:00:03 AM#
    
    'Create the path of the files
    PathFileA = objFolderA.Path & "\" & objFileA.Name
    Debug.Print PathFileA
    PathFileB = objFolderB.Path & "\" & objFileA.Name
    Debug.Print PathFileB
    PathFileC = objFolderC.Path & "\" & objFileA.Name
    Debug.Print PathFileC
    
    If objFileA.Name Like "*.docx" Then
                    
        'Creating object of the word application
        Set wdApp = New Word.Application
        
        'Making visible the word application
        wdApp.Visible = True
        
        'Opening the required word document
        Set WDDocA = wdApp.Documents.Open(PathFileA)
        
        'Opening the required word document
        Set WDDocB = wdApp.Documents.Open(PathFileB)
              
        'Create the file with comparisons
        Set WDDocC = wdApp.CompareDocuments(OriginalDocument:=WDDocA, RevisedDocument:=WDDocB, Destination:=wdCompareDestinationNew, IgnoreAllComparisonWarnings:=True)
        WDDocC.SaveAs FileName:=PathFileC
              
        'Turn off DisplayAlerts
        wdApp.DisplayAlerts = wdAlertsNone
        
        'Close the Summary report
        WDDocC.Close SaveChanges:=False
        
        'Close the documents
        WDDocA.Close
        WDDocB.Close
    End If

        'Update of the progressbar and the label
        k = k + 1
        Me.LabelSummaryReportProgress.Caption = k * 100 / filesNumber & "% Completed"
        
        'Waiting for the refresh of the labels
        DoEvents
        DoEvents
        Application.Wait Now + #12:00:02 AM#
    
    Next objFileA
    Me.LabelSummaryReport.Caption = "The process is complete. Comparison reports have been created."
End Sub


Function ChooseFolder(title) As String
    Dim fldr As FileDialog
    Dim sItem As String
    Dim strPath As String

    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .title = title
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    ChooseFolder = sItem
    Set fldr = Nothing
End Function
 
Solution

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,566
Cross-posted (twice) at:
where comprehensive advice has been given, along with links to code that demonstrates how to address all issues.
Please read Mr Excel's policy on Cross-Posting in rule 13: Message Board Rules
 

Dan_W

Active Member
Joined
Jul 11, 2018
Messages
485
Office Version
  1. 365
Platform
  1. Windows
Re: Cross-Posting - having just looked at the responses you received to your cross-post on other sites, I think I have a greater appreciation for the site's cross-posting rules; namely, it must be very confusing for the person seeking the advice to receive different strands of different thoughts and weave them into one single, workable solution. If you let forum members know where you've asked the same question so they can what else has been tried, then you might actually get to the better solution a lot quicker!

Re: your code - NdNoviceHlp made some very helpful observations, which you've not implemented. There is still a glaring problem with your final code, but if it works, it works. THank you, NdNoviceHlp.
 

Watch MrExcel Video

Forum statistics

Threads
1,133,617
Messages
5,659,882
Members
418,535
Latest member
Ajith55

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top