Consulting

Results 1 to 2 of 2

Thread: Macro not looping through tables

  1. #1

    Macro not looping through tables

    Hello,

    i have this great code thanks to the help of Greg Maxey. Idea is simple - loop through whole document, including headers, and highlight text that is bold or italics. Unfortunately it's not looping through tables and frames - it stucks in first "DoEvents". I have experimented with everything I could find online, but no luck. I was thinking about adding extra part dedicated to looping through tables, but I couldn't adapt anything. So any advise, suggestion will be greatly appreciated

    Here's the code:

    Sub MacroItalics()
    'Helped by Greg Maxey: http://www.vbaexpress.com/forum/show...d=1#post403227
    
    
    Dim rngstory As Word.Range
    Set rngstory = ActiveDocument.StoryRanges(wdMainTextStory)
    Dim lngJunk As Long
    Dim oShp As Shape
    Dim i As Long
    Application.ScreenUpdating = False
    'Fix the skipped blank Header/Footer problem
     lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
     For lngJunk = 1 To 3
      oResetFRParams2 Selection.Range
    
      'Iterate through all story types in the current document
      For Each rngstory In ActiveDocument.StoryRanges
       'Iterate through all linked stories
       Do
         oItalicBold rngstory, lngJunk
           On Error Resume Next
           rngstory.Fields.Update
           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
                      oItalicBold 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
    Application.ScreenUpdating = True
    
    End Sub
    
    
    Private Sub oItalicBold(ByVal rngstory As Word.Range, lngRouter As Long)
    Application.ScreenUpdating = False
    With rngstory.Find
    On Error Resume Next
    
      Select Case lngRouter
    
          Case 1
             .Font.Italic = True
            While .Execute
              rngstory.HighlightColorIndex = wdPink
              rngstory.Collapse wdCollapseEnd
            DoEvents
            Wend
    
          Case 2
            .Font.Bold = True
           While .Execute
             rngstory.HighlightColorIndex = wdPink
             rngstory.Collapse wdCollapseEnd
            DoEvents
            Wend
      End Select
    
    On Error GoTo 0
    End With
    
    ' Application.ScreenUpdating = True
    End Sub
    
    Sub oResetFRParams2(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
    Last edited by macropod; 05-16-2021 at 10:39 PM. Reason: Added code tags & formatting

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    When performing Find/Replace operations based on attributes other that text (e.g. bold, Styles, highlights, shading, etc.) and the content can occur in a table or at the end of the document, additional measures are need. See, for example: https://www.msofficeforums.com/135733-post2.html
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

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