Comparer des documents word et créer un document word avec les différences

Bonjour,

J'essaye de créer un script vba dans un document excel qui permet de comparer des versions de documents Word et de créer un fichier word affichant les différences (track changes). Voici mon 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

J'ai un souci avec la fonction qui permet de sauvegarder le fichier final. Le fichier ne ne sauvegarde pas et je ne sais pas comment faire. Pourriez-vous m'aider s'il vous plaît ?

Pourriez-vous également m'aider également à optimiser ce code si nécessaire.

Merci d'avance