Infinite Loop when Finding Styles

B4rikuda · #1 11-21-2018, 12:29 PM

Hello,

I have been working on a project to help my office to streamline the formatting of our documents. I have created a template for us to use but when we paste documents that already exist, the styles don't update to match the template but rather keep the source formatting. In order to help update the Styles, I scrapped together this code to search through the document to find all Heading Styles and reapply the new Styles to the pasted document. I doubt I am doing this in the most efficient way but it has worked so far.

The issue I run into is this: If the code is looking for all the Heading 1 styles and the last style on the document is Heading 1, it runs into an infinite loop. If it is a different style, it works properly. Can anybody help me to end this madness?

Code:

Sub ChangeActiveDocument()

Dim Answer As String, Bln As Boolean
Bln = True
Dim i As Integer
    
    'Looks for any styles in a Pasted document called Heading 1, 2, or 3 and reapplies the style
    With ActiveDocument
        While Bln
            'Find and select Heading 1
            Set currentRange = ActiveDocument.Range
            currentRange.Find.ClearFormatting
            currentRange.Find.Style = wdStyleHeading1
            currentRange.Find.Wrap = wdFindStop
            currentRange.Find.Forward = True
            currentRange.Find.Text = ""
            i = 1
            bFind = currentRange.Find.Execute

            'Reapply the Heading 1 Style to the selected Heading 1
            Do While bFind 'here is the endless loop
                 'Answer = MsgBox(i & "wdStyleHeading1 " & currentRange.Text, vbOKCancel)
                 currentRange.Style = ActiveDocument.Styles(wdStyleHeading1)
                 currentRange.SetRange currentRange.End, currentRange.End
                 i = i + 1
                 'If currentRange.End = True Then Exit Do
                 bFind = currentRange.Find.Execute
            Loop
            
            'Find and select Heading 2
            Set currentRange = ActiveDocument.Range
            currentRange.Find.ClearFormatting
            currentRange.Find.Style = wdStyleHeading2
            currentRange.Find.Wrap = wdFindStop
            currentRange.Find.Forward = True
            currentRange.Find.Text = ""
            bFind = currentRange.Find.Execute

            'Reapply the Heading 1 Style to the selected Heading 2
            Do While bFind 'here is the endless loop
                 'Answer = MsgBox(i & "wdStyleHeading2 " & currentRange.Text, vbOKCancel)
                 currentRange.Style = ActiveDocument.Styles(wdStyleHeading2)
                 currentRange.SetRange currentRange.End, currentRange.End
                 i = i + 1
                 bFind = currentRange.Find.Execute
            Loop
            
            'Find and select Heading 3
            Set currentRange = ActiveDocument.Range
            currentRange.Find.ClearFormatting
            currentRange.Find.Style = wdStyleHeading3
            currentRange.Find.Wrap = wdFindStop
            currentRange.Find.Forward = True
            currentRange.Find.Text = ""
            bFind = currentRange.Find.Execute

            'Reapply the Heading 1 Style to the selected Heading 3
            Do While bFind 'here is the endless loop
                 'Answer = MsgBox(i & "wdStyleHeading3 " & currentRange.Text, vbOKCancel)
                 currentRange.Style = ActiveDocument.Styles(wdStyleHeading3)
                 currentRange.SetRange currentRange.End, currentRange.End
                 i = i + 1
                 bFind = currentRange.Find.Execute
            Loop
            
        Bln = False
        Wend
    End With
    
    'Looks for any styles in a Pasted document called Epic Title and changes it to Heading 3
    With ActiveDocument
        Set currentRange = ActiveDocument.Range
        currentRange.Find.ClearFormatting
        currentRange.Find.Style = "Epic Title"
        currentRange.Find.Wrap = wdFindStop
        currentRange.Find.Forward = True
        currentRange.Find.Text = ""
        i = 1
        bFind = currentRange.Find.Execute

        Do While bFind 'here is the endless loop
             currentRange.Style = ActiveDocument.Styles(wdStyleHeading3)
             currentRange.SetRange currentRange.End, currentRange.End
             bFind = currentRange.Find.Execute
        Loop
    End With
    
    'Looks for any styles in a Pasted document called Main Topic and changes it to Heading 1
    With ActiveDocument
        Set currentRange = ActiveDocument.Range
        currentRange.Find.ClearFormatting
        currentRange.Find.Style = "Main Topic"
        currentRange.Find.Wrap = wdFindStop
        currentRange.Find.Forward = True
        currentRange.Find.Text = ""
        i = 1
        bFind = currentRange.Find.Execute

        Do While bFind 'here is the endless loop
             currentRange.Style = ActiveDocument.Styles(wdStyleHeading1)
             currentRange.SetRange currentRange.End, currentRange.End
             bFind = currentRange.Find.Execute
        Loop
    End With
    
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Infinite loops occurring in find and replace functions in word macro	Thefirstfish`	Word VBA	5	04-06-2017 07:18 PM
MACRO in infinite loop when it encounters user defined figure label	photoval	Word VBA	3	02-02-2016 08:26 PM
Outlook 2013 - caught in an infinite loop on startup	borderfox	Outlook	0	07-26-2015 01:40 PM
Finding and replacing fonts and styles	Adriano	Word VBA	10	03-17-2013 07:08 PM
'Infinite Loop' error with Infopath 2010	Debbie25	Misc	2	05-18-2011 08:38 AM