'Find and replace not working with trackchanges

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.

The words appear as such:

What I need is that when a word is change such as: AFC - Adminstration Iberia - Accounting Iberia (Energetic Business) it won´t be changed again.

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.

It switches: AFC - Administration Iberia - Accounting Iberia (Energetic Business) FOR ADM Iberia - Accounting Ibe - Negocios Energéticos And because the next word to be changed is similar it changes the part that is the same as if it wasn´t changed: AFC - Administration Iberia - Accounting Iberia FOR BUSTED

As an example: I´m trying to change two words:

AFC admin (ORG)  ----- REVISE
AFC admin       -----  DEBUG

The code procedes and changes "AFC admin (ORG)" for REVISE, but it then goes to change "AFC admin" for DEBUG. Leaving me with two words: DEBUGREVISE. This is due to the trackchanges, when I do it without it, it works fine. Only chainging the sentence once, resulting in only: "AFC admin (ORG)" changed with REVISE.

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.

excel vba ms-word

Solution 1:^[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

Solution 2:^[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.

Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution	Source
Solution 1	macropod
Solution 2	rafael rivera

'Find and replace not working with trackchanges

Solution 1:[1]

Solution 2:[2]

Sources

Related Questions

Solution 1:^[1]

Solution 2:^[2]