Create Word macro to delete text throughout the entire document

[JTell]

I need to create a macro that will turn on change tracking, delete all text that is formatted with red/underline, and then turns off change tracking. I have the macro working for one block of text at a time, but I'd like it to loop through the entire document.
I played a bit with Do Until loops, but this is my first time using Macros in Word and I suspect I am just not experienced enough to get it working... any help is appreciated.

Code:
Sub ClearRed()
'
' ClearRed Macro
'
'
ActiveDocument.TrackRevisions = True
Selection.Find.ClearFormatting
With Selection.Find.Font
.StrikeThrough = True
.DoubleStrikeThrough = False
.Color = wdColorRed
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""


.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveDocument.TrackRevisions = False
End Sub

[gmaxey]

Sub ClearRed1()
Dim oRng As Range
ActiveDocument.TrackRevisions = True
  Selection.Find.ClearFormatting
  Set oRng = ActiveDocument.Range
  With oRng.Find
    With .Font
      .StrikeThrough = True
      .DoubleStrikeThrough = False
      .Color = wdColorRed
    End With
    While .Execute
      oRng.Delete
    Wend
  End With
  ActiveDocument.TrackRevisions = False
lbl_Exit:
  Exit sub

End Sub

[JTell]

That works perfectly - thank you!
Is there any chance you can explain how that works? I have another macro that I need to loop through as well... it will find blue text with an underline, remove the formatting, cut it, turn on change tracking, paste it back in, then turn off change tracking. I've tried to mimic what you had, but it doesn't seem to work...

Code that works (without the loop):
Sub ChangeTrackBlueFont()
'
' ChangeTrackBlueFont Macro
'
'
Selection.Find.ClearFormatting
With Selection.Find.Font
.Underline = wdUnderlineSingle
.Color = wdColorBlue
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Font.UnderlineColor = wdColorAutomatic
Selection.Font.Underline = wdUnderlineNone
Selection.Cut
ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
Selection.PasteAndFormat (wdFormatOriginalFormatting)
ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
End Sub

[gmaxey]

What you posted looks nothing like the solution I posted earlier.

Sub ChangeTrackBlueFont()
Dim oRng As Range
  Selection.Find.ClearFormatting
  Set oRng = ActiveDocument.Range
  With oRng.Find
    With .Font
      .StrikeThrough = True
      .DoubleStrikeThrough = False
      .Color = wdColorBlue
    End With
    While .Execute
      oRng.Delete
    Wend
  End With
  ActiveDocument.TrackRevisions = False
  Set oRng = ActiveDocument.Range
  Selection.Find.ClearFormatting
    With oRng.Find
    With .Font
      .Underline = wdUnderlineSingle
      .Color = wdColorBlue
    End With
    While .Execute
      With oRng.Font
        .UnderlineColor = wdColorAutomatic
        .Underline = wdUnderlineNone
      End With
      oRng.Cut
      ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
      oRng.PasteAndFormat (wdFormatOriginalFormatting)
      ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
    Wend
  End With
lbl_Exit:
  Exit Sub
End Sub

[JTell]

I apologize if I was unclear - I had two macros that needed to loop. I asked the question on the first one, and was hoping that I'd be able to mimic the solution on my second one - but it didn't work.
So I posted the second one to try and get more information.

So you are right - the second one does not look like the first, as I was hoping to understand how to create the loop and do it myself... but it looks like you saved me the effort. It works flawlessly - thank you!

[JTell]

I just noticed that these do not look at the content of footnotes - though they do seem to look at endnotes. Is there something additional that needs to be done to include looping through footnotes?

[gmaxey]

That is because we didn't search in the footnote or endnote story ranges. It also wouldn't find the formatted text in textboxes, headers or footers, comments etc.


Note: Your macros are not processing "real" endnotes.


To search in footnotes and "real" endnotes modify as follows:

Sub ClearRed1()
Dim oRng As Range
ActiveDocument.TrackRevisions = True
  Selection.Find.ClearFormatting
  Set oRng = ActiveDocument.Range
  With oRng.Find
    With .Font
      .StrikeThrough = True
      .DoubleStrikeThrough = False
      .Color = wdColorRed
    End With
    While .Execute
      oRng.Delete
    Wend
  End With
  On Error Resume Next
  Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
  With oRng.Find
    With .Font
      .StrikeThrough = True
      .DoubleStrikeThrough = False
      .Color = wdColorRed
    End With
    While .Execute
      oRng.Delete
    Wend
  End With
  Set oRng = ActiveDocument.StoryRanges(wdEndnotesStory)
  With oRng.Find
    With .Font
      .StrikeThrough = True
      .DoubleStrikeThrough = False
      .Color = wdColorRed
    End With
    While .Execute
      oRng.Delete
    Wend
  End With
  On Error GoTo 0
  ActiveDocument.TrackRevisions = False
lbl_Exit:
  Exit Sub

End Sub

[gmaxey]

You might find this helpful:

Using a Macro to Replace Text Wherever It Appears in a Document

[JTell]

Thank you again - and that article is actually really helpful to explain what's going on. Much appreciated!