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

[amadese57]

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:

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

 

[Dan_W]

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]

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:

WDDocA.Close

the summary file is also closed. And when the line for saving WDDocC:

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]

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]

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

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

 

[Macropod]

Cross-posted (twice) at:

issue in Excel VBA for Creating a word document when comparig 2 versions of a document

In a vba script in an excel document I would like to compare 2 versions of a word document and create a summary Word document with the differences (track changes). Here my script: Option Explicit P...

stackoverflow.com

Comparing Word documents and creating a new document with track changes

I'm trying to create a vba script in an excel document in order to compare Word documents versions and create summary Word documents with the differences (track changes). Here my script: Option Exp...

stackoverflow.com

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]

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.

 

[daustin51]

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

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

Hi There,

are you running this code from excel vba module or word vba module? was asking as I tried to use your code in MS word vba and i'm getting an error on the Me keyword on code line

Me.LabelSummaryReport.Caption = "Please wait..."

and the error is saying invalid use of Me keyword. Please advise if you have a work around for this, thanks.

 

[Dan_W]

Hi There,

are you running this code from excel vba module or word vba module? was asking as I tried to use your code in MS word vba and i'm getting an error on the Me keyword on code line

Me.LabelSummaryReport.Caption = "Please wait..."

and the error is saying invalid use of Me keyword. Please advise if you have a work around for this, thanks.

Hi @daustin51 - judging from the references to Word in the code, we can surmise that it the code was likely being run from Excel. In this particular case, though, the use of Me is a reference to a userform. Looking back over the code, there doesn't seem to be anything here that actually requires a userform in order to work. Hopefully, that helps.

For future reference, new issues like yours should be started under a new thread - if for no other reason than you're more likely to get people help you with your queries than you would by posting on an existing thread (I think only three or so people will have been notified that you had made this post). If it relates to the implementation of the code in this this thread, then it would be extremely helpful if you could link to / reference this thread when you start your own - it will save everyone a whole lot of time!

Do please let me know if you still need help implementing this code into your own project.