Find/replace with track changes not working

[Rafaelete]

Hello,

I´m trying to find and replace multiple sentences from different word files from an specific folder. The words that I´m trying to change are on two columns in excel:

The code is working fine, but due to the specifications of the work that I´m doing, I have to activate trackchanges on each word. The problem with this, is that for some reason, the changes that the find and replace has already done are maintained in the word and makes the sentence appear as if is still there. Even though is changed.
In column B, the last two sentences are the same, but one is longer: AFC - Administration Iberia - Accounting Iberia (Energetic Business). Based on the order that the changes happen, each sentence is change from top to bottom. So this should be replace with "REVISAR" and then the last sentence: AFC- Administration Iberia Accounting Iberia should not be replaced. But here is where I run into a problem:

When I passed the code step by step, it first changed the sentence AFC - Administration Iberia Accounting Iberia (Energetic Business) with REVISAR. But for some reason it still detected the line "AFC - Administration Iberia - Accounting Iberia" and replaced it with DEBUG.

When I run the code with .trackchanges=False the result appears fine. Taking into account the first time the sentence has been changed with "REVISAR", which is what I need with trackchanges=True:

Hopefully I have explained the problem clearly enough.


This is the code that I have developed to make the find and replace on each word (Note:sFileName is just the rute that I use to select all the words).

Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Dim Wrd As New Word.Application
Dim Dict As Object
Dim RefList As Range, RefElem As Range
Dim Key
Dim wrdRng As Range
Dim WDoc As Document


Wrd.Visible = True

Set WDoc = Wrd.Documents.Open(filename:=sFileName, OpenAndRepair:=True) 'Modify as necessary.

Debug.Print sFileName

' Activar control de cambios en cada documento
With WDoc:
.TrackRevisions = True
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
'WDoc.ActiveWindow.View = wdConflictView
End With

'Assigns the columns that is going to have the original texts that need to be changed
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Reemplazos").Range("B2:B50") 'Modify as necessary.


'Selects the column that´s one column to the right of the reference column
With Dict
For Each RefElem In RefList
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
.Add RefElem.Value, RefElem.Offset(0, 1).Value
Debug.Print RefElem
End If
Next RefElem
End With

'Assigns the conditions and loops through each text to replace it
For Each Key In Dict
With WDoc.Content.FIND
Application.ScreenUpdating = False
Debug.Print Key
.ClearFormatting
.Replacement.ClearFormatting
.Text = Key
.Replacement.Text = Dict(Key)
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWildcards = False
.MatchSoundsLike = False
.Execute Replace:=2
End With

Next Key


'Saves, Closes and quits the words.

WDoc.SaveAs NewNewWordName(sFileName)
WDoc.Close
Wrd.Quit




I have been running my head around this problem for a couple of days and can´t seem to find a solution. Any help will be greatly appreciated.

Thanks a lot.