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