Hello, I have a problem with a find and replace in word using excel vba.
The problem I have is with trackchanges. I have to active it due to the requirements of the automatization, but I´m finding myself with two words been changed twice. When I do it without trackchanges it works just fine.
This is an example of the problem I have. These are words that I´m replacing:
The problem I´m having is with these two words:
It changes the first one just fine, but then it changes the second one in the same words as if it wasn´t changed.
This is the result I´m getting:
Without trackchanges, it does the change without any problems:
I need to get this result with trackchanges as true. But I´m unable to do it.
This is the code I´m using:
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 = False
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
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
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
.Execute FindText:=Key, ReplaceWith:=Dict(Key), Replace:=2
End With
Next Key
Any help will be greatly appreciated. Thanks a lot in advance.
The problem I have is with trackchanges. I have to active it due to the requirements of the automatization, but I´m finding myself with two words been changed twice. When I do it without trackchanges it works just fine.
This is an example of the problem I have. These are words that I´m replacing:
| Buscar | Reemplazar |
| Trading - Energy Manag.Ibe | EM Iberia - Strategic Ibe |
| Trading - Iberia (Operations) | REVISAR |
| Trading - Iberia (Int. & Coord. Inf.) | REVISAR |
| REVISAR | REVISAR |
| Responsable actividad | REVISAR |
| Global Hub - Adoption | REVISAR |
| Global Adoption | DISTINTOS NIVELES |
| EM - Ibe | REVISAR |
| EM Inf | REVISAR |
| EM - Operations | REVISAR |
| EM Ibe - Operations | REVISAR |
| AFC - Administration Iberia - Accounting Iberia (Energetic Business) | ADM Iberia - Accounting Ibe - Negocios Energéticos |
| AFC - Administration Iberia - Accounting Iberia | BUSTED |
| ADM Energía | REVISAR |
| AA2 | REVISAR |
| AA1 | REVISAR |
| Activity Owner | REVISAR |
The problem I´m having is with these two words:
It changes the first one just fine, but then it changes the second one in the same words as if it wasn´t changed.
| AFC - Administration Iberia - Accounting Iberia (Energetic Business) | ADM Iberia - Accounting Ibe - Negocios Energéticos |
| AFC - Administration Iberia - Accounting Iberia | BUSTED |
This is the result I´m getting:
Without trackchanges, it does the change without any problems:
I need to get this result with trackchanges as true. But I´m unable to do it.
This is the code I´m using:
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 = False
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
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
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
.Execute FindText:=Key, ReplaceWith:=Dict(Key), Replace:=2
End With
Next Key
Any help will be greatly appreciated. Thanks a lot in advance.
