Microsoft Office Forums - View Single Post - [Solved] Macro Help - Compare current document with another document in the same folder

tanko · 04-02-2021, 11:00 AM

Awesome, thank you. For those searching in the future, I modified the code as follows, and it works great for what I need. This will prompt a filepicker (defaulted to the directory in which the active document is located) to select the document to compare against, run the comparison, and prompt to save as the filename of the revised document, with " - redline" appended. This was designed for use in the legal redline (aka blackline) context. This saves substantial clicking and aggravation when running redlines.

Code:

Sub FastCompare()
Application.ScreenUpdating = False
Dim StrDocOld As String, DocOld As Document
Dim StrDocNew As String, DocNew As Document
Dim DocNewPath As String

Set DocNew = ActiveDocument
StrDocNew = DocNew.FullName
DocNewPath = DocNew.Path

' select "original" document to compare active document against
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
  .Title = "Select the Original Document"
  .AllowMultiSelect = False
  .Filters.Add "Documents", "*.doc; *.docx; *.docm", 1
  .InitialFileName = DocNewPath
  .ButtonName = "Compare"
  If .Show = -1 Then
    StrDocOld = .SelectedItems(1)
  Else
    GoTo ErrExit
  End If
End With

Set DocOld = Documents.Open(StrDocOld)

' run comparison
Dim DocRev As Document

Set DocRev = Application.CompareDocuments( _
  OriginalDocument:=DocOld, RevisedDocument:=DocNew, _
  Destination:=wdCompareDestinationNew, Granularity:=wdGranularityWordLevel, _
  CompareFormatting:=False, CompareCaseChanges:=True, CompareWhitespace:=False, _
  CompareTables:=True, CompareHeaders:=True, CompareFootnotes:=True, _
  CompareTextboxes:=True, CompareFields:=False, CompareComments:=True, _
  CompareMoves:=True, RevisedAuthor:="Author", IgnoreAllComparisonWarnings:=False)

' save comparison with filename of DocNew with " - redline" appended
StrDocNew = Left(StrDocNew, (InStrRev(StrDocNew, ".", -1, vbTextCompare) - 1))

With Application.Dialogs(wdDialogFileSaveAs)
    .Name = StrDocNew & " - redline"
    .Show
End With

' Close DocOld
DocOld.Close
' Bring DocRev to front
DocRev.Activate


Application.ScreenUpdating = True


ErrExit:
Set DocOld = Nothing: Set DocNew = Nothing: Set DocRev = Nothing
End Sub