Option Explicit

Sub TFL_Review()
'Graham Mayor - https://www.gmayor.com - Last updated - 23 Sep 2021
Dim fldrVersion1 As String, fldrVersion2 As String, fldrVersion3 As String
Dim strVersion1 As String, strVersion2 As String
Dim docVersion1 As Document, docVersion2 As Document
Dim docCompareTarget As Document
Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Select the folder that contains the original files."
        If .Show = -1 Then
            fldrVersion1 = .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
            fldrVersion2 = .SelectedItems(1) & Application.PathSeparator
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With

    fldrVersion3 = fldrVersion2 & "\Compared\"
    CreateFolders fldrVersion3
    strVersion1 = Dir$(fldrVersion1 & "*.rtf")
    On Error Resume Next
    While strVersion1 <> ""
        Set docVersion1 = Documents.Open(fldrVersion1 & strVersion1)
        If FileExists(fldrVersion2 & docVersion1.Name) Then
            Set docVersion2 = Documents.Open(fldrVersion2 & docVersion1.Name)
            docVersion1.Compare Name:=docVersion2, CompareTarget:=wdCompareTargetNew
            Set docCompareTarget = ActiveDocument
            docCompareTarget.SaveAs2 fldrVersion3 & docVersion1.Name
            docCompareTarget.Close SaveChanges:=True
        End If
        docVersion1.Close wdDoNotSaveChanges
        docVersion2.Close wdDoNotSaveChanges
        strVersion1 = Dir$()
    Wend
lbl_Exit:
    Exit Sub
End Sub

Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lng_PathSep = InStr(3, strPath, "\")
    If lng_PathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        If lng_PathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lng_PathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
            oFSO.CreateFolder Left(strPath, lng_PathSep)
        End If
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(strFullName) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function