查找并替换不使用轨迹更改的内容

Question

我正试图从特定文件夹的不同单词文件中查找并替换多个句子。我试图更改的单词在excel的两列(B列和C列(更改是正确的，但由于某些原因，单词没有完全删除，更改发生了两次。这是由于这种自动化的要求，需要激活轨迹更改。

现在它做了第一次更改，但后来这个词看起来好像没有更改，所以它用新单词再次进行更改。

这是代码：

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

我想得到一个要求，只有当单词的颜色为黑色时，才能更改单词，因为音轨的更改会使句子的颜色变为红色。但我不知道该怎么做。

Answer 1

在这种情况下，您需要使用Replace以外的东西进行替换。例如：

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

或者，您可以将查找/替换为：

AFC admin       -----  DEBUG

然后

DEBUG (ORG)  ----- REVISE

Answer 2

我找到了这个问题的解决方案：

将Wbk标注为工作簿：设置Wbk=此工作簿将Wrd标注为新单词应用程序Dim Dict As对象标注参照列表为范围，参照元素为范围Dim键Dim wrdRng As Range将WDoc分帐为文档Dim intParaCountDim objParagraphDim 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

这个过程所做的就是改变每个单词的颜色。

我已经指定了一个颜色条件，这样它只会自动更改颜色为的单词：.Font.Color=wdColorAutomatic

一旦更改，音轨内的单词更改将更改为另一种颜色，非常相似但不同：objParagraph.Font.Color=RGB(0，0，1(

这样每个单词只更改一次。这个解决方案的唯一问题是，你需要将所有单词分配给自动颜色或你决定给它的颜色

我希望这能帮助任何发现这个或类似问题的人。

仅供参考，此代码适用于需要更改excel中列中出现的多个单词的人。我发现很多人都有这个问题。所以检查一下代码，它可能会对你有所帮助。