Sub Compare_2_Fldrs()
'Compare similarly-named docs in two folders.

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

strOPath = InputBox("Enter the full path to the folder with original documents:" _
    & vbCr & "e.g.:" & vbCr & "D:\Orig_Fldr\")
strRPath = InputBox("Enter the full path to the folder with revised documents:" _
    & vbCr & "e.g.:" & vbCr & "D:\Revsd_Fldr\")
strCPath = InputBox("Enter the full path to the folder to save the comparisons in:" _
    & vbCr & "e.g.:" & vbCr & "D:\Result_Fldr\")

    Set wd = GetObject(, "Word.Application")
    If wd Is Nothing Then
        Set wd = CreateObject("Word.Application")
    End If
    ReDim Preserve ofiles(0)
    strORTFfile = Dir(strOPath & "" & ("*.docx"), 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:=True, _
            CompareTextboxes:=True, _
            CompareFields:=True, _
            CompareComments:=True, _
            CompareMoves:=True, _
            RevisedAuthor:="Merck & Co., Inc.", _
            IgnoreAllComparisonWarnings:=False)
            
            ActiveWindow.ShowSourceDocuments = wdShowSourceDocumentsNone
            ActiveWindow.Visible = False
            ofiles(i) = Replace(ofiles(i), Chr(13), "")
            nDoc.SaveAs2 fileName:=strCPath & "" & ofiles(i), _
            FileFormat:=wdFormatdocx, 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 = True
        End If
    Next i
End Sub