Find and replace not working with trackchanges - excel

Question

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 (Columns B and C)
The changes are been done correctly, but for some reason the words are not erased completly and the change happens twice. This is due to the trackchanges that needs to be activated due to the requirements of this automation.
Right now it does the first change, but then the word appears as if it wasn´t changed, so it does the change again with the new word.
This is the code:
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
'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
' Activar control de cambios en cada documento
With WDoc:
.TrackRevisions = True
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
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
.Font.Color = vbBlack
.Replacement.Text = Dict(Key)
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
.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 though about getting a requirement of only changing the words when they are on the color black, because the trackchanges leaves the sentence with a color red. But I do not know how to do it.

Answer 1

In cases like this, you need to use something other than Replace for the replacement. For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "AFC admin"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While .Find.Execute
With .Duplicate
If .Words.Last.Next = "(" Then
.MoveEndUntil ")", wdForward
.End = .End + 1
If Split(.Text, " ")(2) = "(ORG)" Then .Text = "REVISE"
Else
.Text = "DEBUG"
End If
End With
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
Alternatively, you might do Find/Replace as:
AFC admin ----- DEBUG
then
DEBUG (ORG) ----- REVISE

Answer 2

I found a solution to this problem:
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
Dim intParaCount
Dim objParagraph
Dim Wordd As Object
Wrd.Visible = True
Set WDoc = Wrd.Documents.Open(filename:=sFileName, OpenAndRepair:=True) 'Modify as necessary.
With WDoc:
.TrackRevisions = True
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
End With
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Reemplazos").Range("B2:B50") 'Modify as necessary.
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
For Each Key In Dict
With WDoc.Content.FIND
Debug.Print Key
.Execute MatchAllWordForms:=False
.Execute Forward:=True
.Execute Wrap:=wdFindAsk
.Execute Format:=False
.Execute MatchCase:=False
.Execute MatchWildcards:=False
.Execute MatchSoundsLike:=False
.Execute wdReplaceAll
.Font.Color = wdColorAutomatic
.Execute FindText:=Key, ReplaceWith:=Dict(Key), Replace:=2
End With
Set objParagraph = WDoc.Content
objParagraph.FIND.Text = Key
Debug.Print Key
Do
objParagraph.FIND.Execute
If objParagraph.FIND.Found Then
objParagraph.Font.Color = RGB(0, 0, 1)
End If
Loop While objParagraph.FIND.Found
Next Key
WDoc.SaveAs NewNewWordName(sFileName)
WDoc.Close
Wrd.Quit
What this process does is change the color of each word once is changed.
I have assigned a color condition so that it only changes words with the color automatic:
.Font.Color = wdColorAutomatic
Once is changed, the word inside track changes are changed to another color, very similar but that are different:
objParagraph.Font.Color = RGB(0, 0, 1)
This way it only changes each word once. The only problem with this solution is that you need to assign all the words to the automatic color or the color you decide to give it.
I hope this helps anyone that found this or a similar problem.
FYI this code works for people that need to change multiple words that appear in columns in excel. I found lots of people with this problem. So check the code and it might help you.