Thread: VBA macro issue
View Single Post
 
Old 10-03-2023, 03:36 PM
VBAlearn VBAlearn is offline Windows 10 Office 2021
Novice
 
Join Date: Oct 2023
Posts: 7
VBAlearn is on a distinguished road
Exclamation VBA macro issue

I am having trouble, with vba macro that I got online to compare two word documents (RTF) files. However I am running an issue can you please help to correct the issue in the file?
Reference VBA MAcro 1: https://www.pharmasug.org/proceeding...020-AD-055.pdf

VBA macro Code

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

strOPath = InputBox("Please enter the folder of original documents:")
strRPath = InputBox("Please enter the folder of revised documents:")
strCPath = InputBox("Please enter the folder to save the comparison: ")

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:=odo c, _
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:=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


End of VBA Macro Code

thanks
Reply With Quote