Microsoft Office Forums - View Single Post - Batch compare word documents with a summary report

eyoung · 05-08-2023, 04:51 AM

I am wanting to write a VBA script that compares a set of documents in one folder with a set of documents in a second folder (they have the same names, generated at different times). The tracked changes comparison is then saved to a third folder. My intention is then to loop through these tracked changes documents and create a summary report that has two tables: 1) Table that specifies the name of the file and whether there were changes or not. 2) Detailed table that specified revisions.

I have the first part of the VBA working, which loops through all the files and successfully saves the tracked changes version.

I have no idea where to even begin with getting the second part (the summary report) up and working.

Code:

Sub Compare()
 Dim wd As Word.Application
 Dim odoc As Word.Document
 Dim rdoc As Word.Document
 Dim strOPath As String
 Dim strRPath As String

 Dim strCPath As String
 Dim strORTFfile As String
 Dim ofiles() As String
 Dim i As Integer
 Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .title = "Select the folder that contains the original files."
        If .Show = -1 Then
            strOPath = .SelectedItems(1) & Application.PathSeparator
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With
    With fd
        .title = "Select the folder that contains the revised files."
        If .Show = -1 Then
            strRPath = .SelectedItems(1) & Application.PathSeparator
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With
    With fd
        .title = "Select the folder where the comparison files will be saved."
        If .Show = -1 Then
            strCPath = .SelectedItems(1) & Application.PathSeparator
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With
 
 Set wd = GetObject(, "Word.Application")
 If wd Is Nothing Then
 Set wd = CreateObject("Word.Application")
 End If
 ReDim Preserve ofiles(0)
 strORTFfile = Dir(strOPath & "\" & ("*.rtf"), vbNormal)

 Do While strORTFfile <> Empty
 ReDim Preserve ofiles(UBound(ofiles) + 1)
 ofiles(UBound(ofiles)) = strORTFfile
 strORTFfile = Dir
 Loop
 
 For i = 1 To UBound(ofiles)
 If Dir(strRPath & "\" & ofiles(i)) <> Empty Then
 Set odoc = wd.Documents.Open(strOPath & "\" & ofiles(i))
 Set rdoc = wd.Documents.Open(strRPath & "\" & ofiles(i))
 Set ndoc = Application.CompareDocuments(OriginalDocument:=odoc, _
 RevisedDocument:=rdoc, _
 Destination:=wdCompareDestinationNew, _
 Granularity:=wdGranularityWordLevel, _
 CompareFormatting:=True, _
 CompareCaseChanges:=True, _
 CompareWhitespace:=True, _
 CompareTables:=True, _
 CompareHeaders:=True, _
 CompareFootnotes:=False, _
 CompareTextboxes:=True, _
 CompareFields:=True, _
 CompareComments:=True, _
 CompareMoves:=True, _
 RevisedAuthor:="USERNAME", _
 IgnoreAllComparisonWarnings:=False)

 ActiveWindow.ShowSourceDocuments = wdShowSourceDocumentsNone
 ActiveWindow.Visible = False
 ofiles(i) = Replace(ofiles(i), Chr(13), "")
 ndoc.SaveAs2 FileName:=strCPath & "\" & ofiles(i), _
 FileFormat:=wdFormatRTF, LockComments:=False, _
 Password:="", AddToRecentFiles:=True, WritePassword:="", _
 ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
 SaveNativePictureFormat:=False, SaveFormsData:=False, _
 SaveAsAOCELetter:=False, CompatibilityMode:=0
 odoc.Close SaveChanges = False
 rdoc.Close SaveChanges = False
 ndoc.Close SaveChanges = False
 End If
 
 Next
 

End Sub