batch compare word file

[maimi23]

I have one folder called "RAW" contains 30 .rtf files, and another folder called "NEW" contains 30 .rtf files with same name with the raw folder.

I can compare them one by one using the word compare option, but it is tedious. Can i have a method to compare them one by one automatically, and store all the compared files with editing mode in a third new folder?

I have wrote a VBA macro, but it can not work accurately:
************************************************** ***
Sub TFL_Review()
Dim fldrVersion1 As String, fldrVersion2 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)
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)
Else
MsgBox "You did not select a folder."
Exit Sub
End If
MsgBox fldrVersion1
End With
'For i = 1 To 2
'fldrVersion1 = fldrVersion1 & "\Folder" & i & ""
'fldrVersion2 = fldrVersion2 & "\Folder" & i & ""
fldrVersion1 = fldrVersion1 & ""
fldrVersion2 = fldrVersion2 & ""
MkDir fldrVersion2 & "Compared"
strVersion1 = Dir$(fldrVersion1 & "*.rtf*")
While strVersion1 <> ""
'Set docVersion1 = Documents.Open(strfldrVersion1 & strVersion1)
'Set docVersion2 = Documents.Open(strfldrVersion1 & docVersion1.Name)
Set docVersion1 = Documents.Open(fldrVersion1 & strVersion1)
Set docVersion2 = Documents.Open(fldrVersion1 & docVersion1.Name)
docVersion1.Compare Name:=docVersion2, CompareTarget:=wdCompareTargetNew
ActiveDocument.SaveAs2 fldrVersion2 & "Compared" & docVersion1.Name
ActiveDocument.Close
docVersion1.Close wdDoNotSaveChanges
docVersion2.Close wdDoNotSaveChanges
strVersion1 = Dir$()
Wend
'Next i


End Sub

[gmayor]

I can't say that Compare is something I have ever had a use for, however try the following:

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