Find and highlight formatting - issue with big documents

Hello,

I have been using following macro to find and highlight all bold elements in documents:

Sub BoldHighlight()

Dim r As Range
Set r = ActiveDocument.Range

With r.Find
.Font.Bold = True
Do While .Execute(Forward:=True) = True
r.HighlightColorIndex = wdGreen
Loop
End With

End Sub


I would really appreciate help in two areas:

1. It works good in small documents, but crashes (freezes Word) when used on bigger documents / documents containing a lot of comments, track changes etc. Does anyone know what could be the issue in that approach and how to fix it? Maybe there is better approach to highlighting bold in the document?

2. Could anyone guide me how to "make it" search for bold in Footnotes as well? I have tried with StoryRanges but with no success, couldn't find any relatable examples.

Thank you in advance!

You might try adding DoEvents before the Loop line. That might prevent the lockup. However, much faster I think would be to create a character style with "shading" vice highlight and then use:

Code:

---

Sub BoldHighlight()
Dim oRng As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Font.Bold = True
    'Create a character style with a "Shaded" background.
    .Replacement.Style = "StrongShaded"
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
  With oRng.Find
    .Font.Bold = True
    'Create a character style with a "Shaded" background.
    .Replacement.Style = "StrongShaded"
    .Execute Replace:=wdReplaceAll
  End With
End Sub

---

Quote:

---

Originally Posted by gmaxey

You might try adding DoEvents before the Loop line. That might prevent the lockup. However, much faster I think would be to create a character style with "shading" vice highlight and then use:

Code:

---

Sub BoldHighlight()
Dim oRng As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Font.Bold = True
    'Create a character style with a "Shaded" background.
    .Replacement.Style = "StrongShaded"
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
  With oRng.Find
    .Font.Bold = True
    'Create a character style with a "Shaded" background.
    .Replacement.Style = "StrongShaded"
    .Execute Replace:=wdReplaceAll
  End With
End Sub

---

---

Thank you for the answer. Unfortunately I need to use the approach that doesn't require additional setting of the style, since I must assume other people will be using it as well. Other thing is that I need to use analogical approach to highlight italics / underline as well.

Adding a loop makes macro run, but it seems to be "running eternally", I need to stop it manually. Do you have any advice?


The idea of the macro is: loop through the full document, including footnotes, find bold and highlight it.


Really appreciate the help.

Code:

---

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape

'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
ResetFRParameters Selection.Range
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
  'Iterate through all linked stories
  Do
    SrcAndRplInStory rngStory
    On Error Resume Next
    Select Case rngStory.StoryType
      Case 6, 7, 8, 9, 10, 11
        If rngStory.ShapeRange.Count > 0 Then
          For Each oShp In rngStory.ShapeRange
            If Not oShp.TextFrame.TextRange Is Nothing Then
              SrcAndRplInStory oShp.TextFrame.TextRange
            End If
          Next
        End If
      Case Else
        'Do Nothing
    End Select
    On Error GoTo 0
    'Get next linked story (if any)
    Set rngStory = rngStory.NextStoryRange
  Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range)
With rngStory.Find
  .Font.Bold = True
  While .Execute
    rngStory.HighlightColorIndex = wdGreen
    DoEvents
  Wend
End With
End Sub
Sub ResetFRParameters(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

---

Quote:

---

Originally Posted by gmaxey

Code:

---

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape

'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
ResetFRParameters Selection.Range
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
  'Iterate through all linked stories
  Do
    SrcAndRplInStory rngStory
    On Error Resume Next
    Select Case rngStory.StoryType
      Case 6, 7, 8, 9, 10, 11
        If rngStory.ShapeRange.Count > 0 Then
          For Each oShp In rngStory.ShapeRange
            If Not oShp.TextFrame.TextRange Is Nothing Then
              SrcAndRplInStory oShp.TextFrame.TextRange
            End If
          Next
        End If
      Case Else
        'Do Nothing
    End Select
    On Error GoTo 0
    'Get next linked story (if any)
    Set rngStory = rngStory.NextStoryRange
  Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range)
With rngStory.Find
  .Font.Bold = True
  While .Execute
    rngStory.HighlightColorIndex = wdGreen
    DoEvents
  Wend
End With
End Sub
Sub ResetFRParameters(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

---

---

Thank you so much, this works perfectly! Can I have one more question, i am not asking for a code, just for guidance - can I adapt this code to use for finding italics/undeline? I tried with replacing " .Font.Bold = True" to .Italic but no luck here. Thank you so much if you can answer this question as well :)

Any one of these works here;

Code:

---

Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range)
With rngStory.Find
  .Font.Underline = True
  '.Font.Italic = True
  '.Font.Bold = True
  While .Execute
    rngStory.HighlightColorIndex = wdGreen
    DoEvents
  Wend
End With
End Sub

---

Hi Greg, thank you! I am soo grateful, and so embarrassed to ask... but... I'm trying to combine those three searches: loop through document to find italics, then loop through document to find bold, and then loop through document to find underline. I tried recreating Subs and calling on them, but it creates "infinite loop". Again, I am not asking for a code, but if you're not yet tired of me, any additional guidance will be very helpful.

And, again - thank you so much for your help, I was stuck on this for such a long time!

Code:

---

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape

'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  For lngJunk = 1 To 3
    ResetFRParams Selection.Range
   
    'Iterate through all story types in the current document
    For Each rngStory In ActiveDocument.StoryRanges
      'Iterate through all linked stories
      Do
        SrcAndRplInStory rngStory, lngJunk
        On Error Resume Next
        Select Case rngStory.StoryType
          Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
              For Each oShp In rngStory.ShapeRange
                If Not oShp.TextFrame.TextRange Is Nothing Then
                  SrcAndRplInStory oShp.TextFrame.TextRange, lngJunk
                End If
              Next
            End If
          Case Else
            'Do Nothing
        End Select
        On Error GoTo 0
        'Get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
      Loop Until rngStory Is Nothing
    Next
  Next lngJunk
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
With rngStory.Find
  Select Case lngRouter
    Case 1: .Font.Bold = True
    Case 2: .Font.Italic = True
    Case 3: .Font.Underline = wdUnderlineSingle
  End Select
  While .Execute
    rngStory.HighlightColorIndex = wdGreen
    DoEvents
  Wend
End With
End Sub
Sub ResetFRParams(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

---

Quote:

---

Originally Posted by gmaxey

Code:

---

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape

'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  For lngJunk = 1 To 3
    ResetFRParams Selection.Range
   
    'Iterate through all story types in the current document
    For Each rngStory In ActiveDocument.StoryRanges
      'Iterate through all linked stories
      Do
        SrcAndRplInStory rngStory, lngJunk
        On Error Resume Next
        Select Case rngStory.StoryType
          Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
              For Each oShp In rngStory.ShapeRange
                If Not oShp.TextFrame.TextRange Is Nothing Then
                  SrcAndRplInStory oShp.TextFrame.TextRange, lngJunk
                End If
              Next
            End If
          Case Else
            'Do Nothing
        End Select
        On Error GoTo 0
        'Get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
      Loop Until rngStory Is Nothing
    Next
  Next lngJunk
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
With rngStory.Find
  Select Case lngRouter
    Case 1: .Font.Bold = True
    Case 2: .Font.Italic = True
    Case 3: .Font.Underline = wdUnderlineSingle
  End Select
  While .Execute
    rngStory.HighlightColorIndex = wdGreen
    DoEvents
  Wend
End With
End Sub
Sub ResetFRParams(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

---

---

Thank you, thank you so much! You're truly a guru!

I don't see why this wouldn't work:

Code:

---

Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
  With rngStory.Find
    Select Case lngRouter
      Case 1
        .Font.Bold = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          DoEvents
        Wend
      Case 2
        .Font.Italic = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          DoEvents
        Wend
      Case 3
        .Font.Underline = wdUnderlineSingle
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
        DoEvents
        Wend
    End Select
  End With
End Sub

---

Quote:

---

Originally Posted by gmaxey

I don't see why this wouldn't work:

Code:

---

Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
  With rngStory.Find
    Select Case lngRouter
      Case 1
        .Font.Bold = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          DoEvents
        Wend
      Case 2
        .Font.Italic = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          DoEvents
        Wend
      Case 3
        .Font.Underline = wdUnderlineSingle
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
        DoEvents
        Wend
    End Select
  End With
End Sub

---

---

Thank you! I did some tests and with big document with comments and track changes it unfortunately stucks on the first "DoEvents" section and loops through over and over... Any idea what could be the reason?

You might try:

Code:

---

Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
  With rngStory.Find
    Select Case lngRouter
      Case 1
        .Font.Bold = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 2
        .Font.Italic = True
        While .Execute
          rngStory.HighlightColorIndex = wdRed
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 3
        .Font.Underline = wdUnderlineSingle
        While .Execute
          rngStory.HighlightColorIndex = wdYellow
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
    End Select
  End With
End Sub

---

Quote:

---

Originally Posted by gmaxey

You might try:

Code:

---

Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
  With rngStory.Find
    Select Case lngRouter
      Case 1
        .Font.Bold = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 2
        .Font.Italic = True
        While .Execute
          rngStory.HighlightColorIndex = wdRed
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 3
        .Font.Underline = wdUnderlineSingle
        While .Execute
          rngStory.HighlightColorIndex = wdYellow
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
    End Select
  End With
End Sub

---

---

Dear Greg, this is perfect, thank you! I can't tell you how much time I have spent trying to figure this out... and you made it look so elegant and easy! THANK YOU, and thank you for all the follow-ups!!!

You're welcome. Spending time figuring these things out is how one learns to figure them out.

Quote:

---

Originally Posted by rook

Dear Greg, this is perfect, thank you! I can't tell you how much time I have spent trying to figure this out... and you made it look so elegant and easy! THANK YOU, and thank you for all the follow-ups!!!

---

Hi guys... me again :) Do you have any advice on how to make the macro search through the "text frames" (drawing objects)? Further testing showed that I get error when text is in the frame - I either get: "The HighlightColorIndex method or property is not available because the object refers to the drawing object". In other cases I don't get this error, but the text in the frame doesn't get highlighted.

I tried adding wdTextFrameStory (5) but it didn't help.

[Edit - ignoring text frames is also a possibility, just so it wouldn't stop the macro]

Any tip will be appreciated!

Rook,

Seems to work fine here:
Attachment 26898

But if you want skip the TextFrame story, see below and unstet the appropriate line:

Code:

---

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape

'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  For lngJunk = 1 To 3
    ResetFRParams Selection.Range
   
    'Iterate through all story types in the current document
    For Each rngStory In ActiveDocument.StoryRanges
      'Iterate through all linked stories
      Do
        'If rngStory.StoryType = 5 Then Exit Do
        SrcAndRplInStory rngStory, lngJunk
       
        On Error Resume Next
        Select Case rngStory.StoryType
          Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
              For Each oShp In rngStory.ShapeRange
                If Not oShp.TextFrame.TextRange Is Nothing Then
                  SrcAndRplInStory oShp.TextFrame.TextRange, lngJunk
                End If
              Next
            End If
          Case Else
            'Do Nothing
        End Select
        On Error GoTo 0
        'Get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
      Loop Until rngStory Is Nothing
    Next
  Next lngJunk
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
  With rngStory.Find
    Select Case lngRouter
      Case 1
        .Font.Bold = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 2
        .Font.Italic = True
        While .Execute
          rngStory.HighlightColorIndex = wdRed
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 3
        .Font.Underline = wdUnderlineSingle
        While .Execute
          rngStory.HighlightColorIndex = wdYellow
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
    End Select
  End With
End Sub
Sub ResetFRParams(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

---

Quote:

---

Originally Posted by gmaxey

Rook,

Seems to work fine here:
Attachment 26898

But if you want skip the TextFrame story, see below and unstet the appropriate line:

Code:

---

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape

'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  For lngJunk = 1 To 3
    ResetFRParams Selection.Range
   
    'Iterate through all story types in the current document
    For Each rngStory In ActiveDocument.StoryRanges
      'Iterate through all linked stories
      Do
        'If rngStory.StoryType = 5 Then Exit Do
        SrcAndRplInStory rngStory, lngJunk
       
        On Error Resume Next
        Select Case rngStory.StoryType
          Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
              For Each oShp In rngStory.ShapeRange
                If Not oShp.TextFrame.TextRange Is Nothing Then
                  SrcAndRplInStory oShp.TextFrame.TextRange, lngJunk
                End If
              Next
            End If
          Case Else
            'Do Nothing
        End Select
        On Error GoTo 0
        'Get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
      Loop Until rngStory Is Nothing
    Next
  Next lngJunk
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
  With rngStory.Find
    Select Case lngRouter
      Case 1
        .Font.Bold = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 2
        .Font.Italic = True
        While .Execute
          rngStory.HighlightColorIndex = wdRed
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 3
        .Font.Underline = wdUnderlineSingle
        While .Execute
          rngStory.HighlightColorIndex = wdYellow
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
    End Select
  End With
End Sub
Sub ResetFRParams(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

---

---

Hi Greg, thank you. On my end it doesn't highlight text in the frame Attachment 26900(1). I tried the code you just shared and on my end it stucks in the first "Do Events" (2) and in the big document it again gives the Error 4605 (3).

Any advice on what could be causing that behavior since it is behaving correctly on your end?

Thank you!

Not really. Not without access to the part of your document throwing the error. Wrap that whole Select Case lngRouter block in an On Error Resume Next ...
On Error GoTo 0.

Quote:

---

Originally Posted by gmaxey

Not really. Not without access to the part of your document throwing the error. Wrap that whole Select Case lngRouter block in an On Error Resume Next ...
On Error GoTo 0.

---

I will do that, Thank you!!!!