Finding and redacting Highlighted text in yellow

Question

I have the VBA code below (from another chat) which looks for highlighted and underlined text in a Word document and redacts it (i.e. replaces it with "x"s and highlights in black).

I would like to identify and redact only text highlighted in yellow.

It does not work on any document (complex or less complex).

Sub Redact()

' Redact Macro
' Macro to redact underlined text
' If redacted, text will be replaced by x's, coloured black and highlighted black

Dim OldText, OldLastChar, NewLastChar, NewText, ReplaceChar As String
Dim RedactForm As Integer
Dim flag As Boolean

Application.ScreenUpdating = False

ReplaceChar = "x"

'Make sure to start at the beginning of the document
Selection.HomeKey wdStory
Do
 ' Find next underline with highlight
    Selection.Find.ClearFormatting
    Selection.Find.Font.Underline = wdUnderlineSingle
    Selection.Find.Highlight = True
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    flag = Selection.Find.Execute
    If flag Then
        If Selection.Range.HighlightColorIndex = wdYellow Then
            ' Create replacement string
            ' If last character is a carriage return (unicode 13), then keep that carriage return
            OldText = Selection.Text
            OldLastChar = Right(OldText, 1)
            NewLastChar = ReplaceChar
            If OldLastChar Like "[?*#]" Then NewLastChar = String(1, 13)
            NewText = String(Len(OldText) - 1, ReplaceChar) & NewLastChar

            ' Replace text, black block
            Selection.Text = NewText
            Selection.Font.ColorIndex = wdBlack
            Selection.Font.Underline = False
            Selection.Range.HighlightColorIndex = wdBlack
            Selection.Collapse wdCollapseEnd
        End If
    End If

Loop While flag

Application.ScreenUpdating = True

End Sub

Thanks for your help.

Best, Carine

macropod · Answer

For some true redaction, try:

Sub RedactMe()
Application.ScreenUpdating = False
Dim wdPage As Page, wdRct As Rectangle, wdLine As Line, Rng As Range, sWdth As Single
For Each wdPage In ActiveDocument.ActiveWindow.Panes(1).Pages
  For Each wdRct In wdPage.Rectangles
    For Each wdLine In wdRct.Lines
      Set Rng = wdLine.Range
      With wdLine.Range
        If .Characters.Last.Text Like "[ " & Chr(160) & Chr(9) & "-" & Chr(13) & "]" Then
          .Characters.Last.HighlightColorIndex = wdNoHighlight
        End If
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Highlight = True
          .Wrap = wdFindStop
          .Text = ""
          .Replacement.Text = ""
          .Execute
        End With
        If .Find.Found = True Then
          If .End > Rng.End Then .End = Rng.End
        End If
        Do While .Find.Found = True
          If .InRange(Rng) = False Then Exit Do
          If .HighlightColorIndex = wdYellow Then
            .Fields.Unlink
            .HighlightColorIndex = wdBlack
            sWdth = .Characters.Last.Next.Information(wdHorizontalPositionRelativeToPage) - _
              .Characters.First.Information(wdHorizontalPositionRelativeToPage)
            .Text = Chr(160) & Chr(160)
            .FitTextWidth = sWdth
          End If
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
      End With
    Next
  Next
Next
Application.ScreenUpdating = True
End Sub

Finding and redacting Highlighted text in yellow

1 Answers