Find and highlight formatting - issue with big documents

[rook]

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!

[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:


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

[rook]

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:


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.

[gmaxey]

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

[rook]

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 :)

[gmaxey]

Any one of these works here;


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

[rook]

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!

[gmaxey]

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

[rook]

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!

[gmaxey]

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

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

[rook]

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

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?

[gmaxey]

You might try:

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

[rook]

You might try:

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!!!

[gmaxey]

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

[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!

[gmaxey]

Rook,

Seems to work fine here:
26898

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


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

[rook]

Rook,

Seems to work fine here:
26898

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


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 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!

[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.

[rook]

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!!!!