[Solved] Word macro: highlight specific text that are with track changes

[Annayyyyyy]

Hi everyone,

I am interested in creating a Word macro that can be used to highlight particular text that is marked with track changes.

For example, the following code can highlight all text that is marked with track changes:

Code: Select all

Sub Highlight_Tracked_Changes()

    Dim rev As Revision
    ' Turn off track changes
    ActiveDocument.TrackRevisions = False
    ' Show revisions
    With ActiveWindow.View.RevisionsFilter
        .Markup = wdRevisionsMarkupAll
        .View = wdRevisionsViewFinal
    End With
    For Each rev In ActiveDocument.Revisions
        rev.Range.HighlightColorIndex = wdYellow
    Next rev
    
End Sub

Here's another macro that can highlight text according to Excel named range:

Code: Select all

Sub Highlight_Words()

Const strWorkbook As String = "C:\Users\Downloads\WordList.xlsx" 'The workbook path
Const strRange As String = "Wordlist"

Dim Arr() As Variant, lngRows As Long, oRng As Range, strFind As String, bWC As Boolean
  Arr = xlFillArray(strWorkbook, strRange)
  For lngRows = 0 To UBound(Arr, 2)
    strFind = Arr(0, lngRows)
    Set oRng = ActiveDocument.Range
    
    With oRng.Find
      .MatchCase = False
      bWC = Arr(2, lngRows) = "T"   'assumes named range includes at least 3 columns with no empty cells
      .MatchWildcards = bWC
      Do While .Execute(FindText:=strFind)
        oRng.HighlightColorIndex = wdYellow
        oRng.Collapse 0
        
      Loop
    End With
  Next lngRows
lbl_Exit:
  Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant

Dim RS As Object
Dim CN As Object
Dim iRows As Long

    strRange = strRange & "]"
    Set CN = CreateObject("ADODB.Connection")

    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"""

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

Is it possible to merge them together so that the macro can highlight specific text that has been marked with track changes? Alternatively, are there any other methods available to accomplish this? Thank you in advance for your assistance!

[HansV]

Welcome to Eileen's Lounge.

Try the following. The code for xFillArray remains the same.

Code: Select all

Sub Highlight_Words()

    Const strWorkbook As String = "C:\Users\Downloads\WordList.xlsx" 'The workbook path
    Const strRange As String = "Wordlist"

    Dim Arr() As Variant, lngRows As Long, oRng As Range, strFind As String, bWC As Boolean

    ' Turn off track changes
    ActiveDocument.TrackRevisions = False
    ' Show revisions
    With ActiveWindow.View.RevisionsFilter
        .Markup = wdRevisionsMarkupAll
        .View = wdRevisionsViewFinal
    End With

    Arr = xlFillArray(strWorkbook, strRange)
    For lngRows = 0 To UBound(Arr, 2)
        strFind = Arr(0, lngRows)
        Set oRng = ActiveDocument.Range
    
        With oRng.Find
            .MatchCase = False
            bWC = Arr(2, lngRows) = "T"   'assumes named range includes at least 3 columns with no empty cells
            .MatchWildcards = bWC
            Do While .Execute(FindText:=strFind)
                If oRng.Revisions(1).Range.Start = oRng.Start And oRng.Revisions(1).Range.End = oRng.End Then
                    oRng.HighlightColorIndex = wdYellow
                End If
                oRng.Collapse 0
            Loop
        End With
    Next lngRows
End Sub

[Annayyyyyy]

Welcome to Eileen's Lounge.

Try the following. The code for xFillArray remains the same.

Code: Select all

Sub Highlight_Words()

    Const strWorkbook As String = "C:\Users\Downloads\WordList.xlsx" 'The workbook path
    Const strRange As String = "Wordlist"

    Dim Arr() As Variant, lngRows As Long, oRng As Range, strFind As String, bWC As Boolean

    ' Turn off track changes
    ActiveDocument.TrackRevisions = False
    ' Show revisions
    With ActiveWindow.View.RevisionsFilter
        .Markup = wdRevisionsMarkupAll
        .View = wdRevisionsViewFinal
    End With

    Arr = xlFillArray(strWorkbook, strRange)
    For lngRows = 0 To UBound(Arr, 2)
        strFind = Arr(0, lngRows)
        Set oRng = ActiveDocument.Range
    
        With oRng.Find
            .MatchCase = False
            bWC = Arr(2, lngRows) = "T"   'assumes named range includes at least 3 columns with no empty cells
            .MatchWildcards = bWC
            Do While .Execute(FindText:=strFind)
                If oRng.Revisions(1).Range.Start = oRng.Start And oRng.Revisions(1).Range.End = oRng.End Then
                    oRng.HighlightColorIndex = wdYellow
                End If
                oRng.Collapse 0
            Loop
        End With
    Next lngRows
End Sub

Thank you very much for your assistance. I have discovered an alternative approach to accomplish it. Firstly, I highlighted the specific words according to an Excel file. Then, I utilized a different code to substitute the words based on an Excel file, while also enabling track changes. As a result, the designated words were highlighted and replaced with track changes.