Consulting

Results 1 to 19 of 19

Thread: Find and highlight formatting - issue with big documents

  1. #1

    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!

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    Quote Originally Posted by gmaxey View Post
    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.

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    Quote Originally Posted by gmaxey View Post
    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

  6. #6
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

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

  8. #8
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  9. #9
    Quote Originally Posted by gmaxey View Post
    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!

  10. #10
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  11. #11
    Quote Originally Posted by gmaxey View Post
    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?

  12. #12
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  13. #13
    Quote Originally Posted by gmaxey View Post
    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!!!

  14. #14
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    You're welcome. Spending time figuring these things out is how one learns to figure them out.
    Greg

    Visit my website: http://gregmaxey.com

  15. #15
    Quote Originally Posted by rook View Post
    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!
    Last edited by rook; 07-02-2020 at 07:18 AM.

  16. #16
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    Rook,

    Seems to work fine here:
    Results.jpg

    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
    Greg

    Visit my website: http://gregmaxey.com

  17. #17
    Quote Originally Posted by gmaxey View Post
    Rook,

    Seems to work fine here:
    Results.jpg

    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 example1.jpg(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!

  18. #18
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,129
    Location
    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.
    Greg

    Visit my website: http://gregmaxey.com

  19. #19
    Quote Originally Posted by gmaxey View Post
    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!!!!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •