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