Batch compare word documents with a summary report

eyoung · #1 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

Guessed · #2 05-08-2023, 04:56 PM

I've done such a macro to gather metrics and detail the comments. I'm not convinced that detailing all the revisions is actually useful since the context of additions and deletions is important and there isn't much value in seeing just the deletion/addition in a sterile environment.

Since the macro I have is quite involved and proprietary, I'm not going to share all its workings in one go but can help guide you through the development of your macro and help you with any sticking points.

Let's start with the basic idea of:
1. In an empty Word doc (aDoc), add a table (aTbl) to collect the statistics of each document examined. Add columns for filename, # comments, # revisions, etc
2. Start looping through a folder of documents. Open each doc and:
a. add a row to aTbl and report the current doc's basic info
b. While the current doc is open, at the end of aDoc insert the doc name and apply Heading style to it. Then if the revision count > 0 add a table below the heading to collect the revision info.

Here is step 1 along with most of the variables you will need for later steps.

Code:

  Dim objFSO As Object, objFolder As Object, objFile As Object
  Dim i As Integer, sPath As String, aPict As InlineShape, dblRatio As Double
  Dim aRng As Range, aRngHead As Range, aRngScope As Range, sFile As String
  Dim aShp As Shape, aDoc As Document, aDocSrc As Document, sVal As String
  Dim aTbl As Table, aTblComm As Table, aRow As Row, aComment As Comment
  Dim aFld As Field, sClass As String
  
  Set aDoc = ActiveDocument
  
  'Setup Log Table
  Set aTbl = aDoc.Tables.Add(aDoc.Range, 1, 4)
  With aTbl
    .Cell(1, 1).Range.Text = "Filename"
    .Cell(1, 2).Range.Text = "Comments"
    .Cell(1, 3).Range.Text = "Tracked Revs"
    .Cell(1, 4).Range.Text = "Other"
    .PreferredWidthType = wdPreferredWidthPercent
    .PreferredWidth = 100
    .Columns.PreferredWidthType = wdPreferredWidthPercent
    .Columns.PreferredWidth = 10
    .Columns(1).PreferredWidth = 70     '100 - (.Columns.Count - 1) * 10
  End With

If you get this first bit working, report back on what form the tracked revisions should take when you extract them to this summary doc. Post an example doc showing what you think it should contain to be meaningful to the reader. How would you want to show deleted/added graphics, table cells, large ranges etc?

eyoung · #3 05-09-2023, 05:00 PM

Great news - I have been able to create what I need. The logic of stepping through the process is what I was missing, and the code I ended up using is a bit different to the snippet you provided.

Thankfully my situation is quite specific and narrow in that all the documents I am comparing are tables and text only, no figures.

As correctly pointed out, I immediately saw the issue with my original approach if I was going to capture all the specific revisions, so instead I created a summary report which will state whether there were updates or not, and then the number of revisions.

Code:

Sub TCwithSummReport()
 Dim wd As Word.Application
 Dim oDoc As Word.Document
 Dim rdoc As Word.Document
 Dim oTCDoc As Document
 Dim oNewDoc As Document
 Dim oTable As Table
 Dim oRow As Row
 Dim oCol As Column
 Dim oRange As Range
 Dim oRevision As Revision
 Dim strText As String
 Dim n As Long
 Dim j As Long
 Dim Title As String

 Dim strOPath As String
 Dim strRPath As String

 Dim strCPath As String
 Dim strORTFfile As String
 Dim ofiles() As String
 Dim i As Integer
 
 ' User identification of folders containing original and revised versions, as well as the folder where the tracked changes comparison are to be saved
 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)

'Create a new document for the tracked changes, base on Normal.dot
Set oNewDoc = Documents.Add

'Set orientation and borders, and add a table
oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc
    .Content = ""
    With .PageSetup
        .LeftMargin = CentimetersToPoints(2)
        .RightMargin = CentimetersToPoints(2)
        .TopMargin = CentimetersToPoints(2.5)
    End With
End With
        
'Adjust the Normal style and Header style
With oNewDoc.Styles(wdStyleNormal)
    With .Font
        .Name = "Arial"
        .Size = 9
        .Bold = False
    End With
    With .ParagraphFormat
        .LeftIndent = 0
        .SpaceAfter = 0
    End With
End With

With oNewDoc.Styles(wdStyleHeader)
    .Font.Size = 8
    .ParagraphFormat.SpaceAfter = 0
End With

'Add text that identifies the folder paths that were checked
Selection.Style = ActiveDocument.Styles("Heading 1")
Selection.TypeText text:="Tracked Changes Summary Report"
Selection.TypeParagraph
Selection.Font.Bold = wdToggle
Selection.TypeText text:="Original: " & vbTab
Selection.Font.Bold = wdToggle
Selection.TypeText text:=strOPath
Selection.TypeParagraph
Selection.Font.Bold = wdToggle
Selection.TypeText text:="Revised: " & vbTab
Selection.Font.Bold = wdToggle
Selection.TypeText text:=strRPath
Selection.TypeParagraph
Selection.TypeParagraph

'Add table with 3 columns
With oNewDoc
    Set oTable = .Tables.Add _
        (Range:=Selection.Range, _
        numrows:=1, _
        NumColumns:=3)
End With

'Set a style for the table and set widths
With oTable
    .Range.Style = wdStyleTableLightShadingAccent1
    .AllowAutoFit = False
    .PreferredWidthType = wdPreferredWidthPercent
    .PreferredWidth = 100
    For Each oCol In .Columns
        oCol.PreferredWidthType = wdPreferredWidthPercent
    Next oCol
    .Columns(1).PreferredWidth = 60 'Document
    .Columns(2).PreferredWidth = 25  'Status
    .Columns(3).PreferredWidth = 15  'Count
End With

'Insert table headings
With oTable.Rows(1)
    .Cells(1).Range.text = "Document"
    .Cells(2).Range.text = "Status"
    .Cells(3).Range.text = "Count"
End With

'Generate the tracked changes comparisons (Note: Footnotes set to False to avoid all documents having changes due to different date/times the documents were generated)

 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:="Elisa Young", _
     IgnoreAllComparisonWarnings:=False)
     
     ofiles(i) = Replace(ofiles(i), Chr(13), "")
     
     ChDir strCPath
     ndoc.SaveAs2 FileName:=ofiles(i), _
     FileFormat:=wdFormatRTF, LockComments:=False, _
     Password:="", AddToRecentFiles:=True, WritePassword:="", _
     ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
     SaveNativePictureFormat:=False, SaveFormsData:=False, _
     SaveAsAOCELetter:=False, CompatibilityMode:=0
     
    ' Get info from each tracked change (insertion/deletion) from oTCDoc and insert in table
    Set oTCDoc = ActiveDocument
       
    If oTCDoc.Revisions.Count = 0 Then
        Set oRow = oTable.Rows.Add
        With oRow
        .Cells(1).Range.text = ndoc
        .Cells(1).Range.Font.TextColor = wdColorBlack
        .Cells(2).Range.text = "No Change"
        .Cells(2).Range.Font.TextColor = wdColorBlack
        End With
    Else
        Set oRow = oTable.Rows.Add
        With oRow
        .Cells(1).Range.text = oTCDoc
        .Cells(1).Range.Font.TextColor = wdColorBlack
        .Cells(2).Range.text = "Updates"
        .Cells(2).Range.Font.TextColor = wdColorRed
        .Cells(3).Range.text = oTCDoc.Revisions.Count
        .Cells(3).Range.Font.TextColor = wdColorRed
        End With
    End If
    
    'Save the new summary report
     oNewDoc.SaveAs2 FileName:=strCPath & "\Tracked Changes Summary Report.docx", _
     FileFormat:=wdFormatDocumentDefault
     
     'Close all documents except the new summary report
     ActiveWindow.ShowSourceDocuments = wdShowSourceDocumentsNone
     ActiveWindow.Visible = False
     oTCDoc.Close savechanges = False
     rdoc.Close savechanges = False
     oDoc.Close savechanges = False

 End If
 
 Next
 

End Sub

Thread Tools
Show Printable Version Email this Page
Display Modes
Switch to Linear Mode Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
batch compare word file	maimi23	Word VBA	1	09-23-2021 04:21 AM
Batch merging of Word documents	Harry Gateaux	Word VBA	6	11-19-2020 09:58 AM
Batch Editing Word documents	sakhtar6	Word VBA	6	03-02-2020 02:49 PM
Batch create Word documents	cdfj	Word VBA	6	11-07-2012 01:03 PM
Can you compare two word documents? (Automatically)	admin4ever	Word	2	05-17-2011 09:44 AM