#1
|
|||
|
|||
Infinite Loop when Finding Styles
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 Last edited by macropod; 11-21-2018 at 03:32 PM. Reason: Replaced QUOTE tags with CODE tags |
#2
|
||||
|
||||
Try something based on:
Code:
Sub ChangeActiveDocument() Application.ScreenUpdating = False Dim ArrStlFnd(), ArrStlRep(), i As Long ArrStlFnd = Array("Heading 1", "Heading 2", "Heading 3", "Main Topic", "Epic Title") ArrStlRep = Array("Heading 1", "Heading 2", "Heading 3", "Heading 1", "Heading 3") For i = 0 To UBound(ArrStlFnd) With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "" .Replacement.Text = "" .Forward = True .Format = True .Style = ArrStlFnd(i) .Wrap = wdFindStop .Execute End With Do While .Find.Found .Style = ArrStlRep(i) .ParagraphFormat.Reset .Font.Reset If .Information(wdWithInTable) = True Then If .End = .Cells(1).Range.End - 1 Then .End = .Cells(1).Range.End .Collapse wdCollapseEnd If .Information(wdAtEndOfRowMarker) = True Then .End = .End + 1 End If End If End If If .End = ActiveDocument.Range.End Then Exit Do .Collapse wdCollapseEnd .Find.Execute Loop End With Next Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
That worked wonderfully, macropod! Thank you!
|
#4
|
||||
|
||||
I would approach this task from a different direction.
Firstly, if you have control of the receiving file PRIOR to introducing the other content, add a couple of aliases to the heading styles so that the conversion of Epic Title and Main Topic to headings happens automatically as you paste. Add an alias to Heading 3 by modifying the style for Heading 3 so its name is "Heading 3,Epic Title". Do the same for Heading 1 so its name becomes "Heading 1,Main Topic". Note: You can't add an alias if that style name already exists in the document so it has to happen BEFORE pasting in the content from the other source. But once it is done, anything that was styled with either Heading 3 OR Epic Title will paste into the document as Heading 3. So then, all that remains is the question you posted about. I would rewrite that part of the macro along the following lines. Code:
Sub ChangeActiveDocument() Dim aRng As Range, iHeadStyleID As Integer For iHeadStyleID = -4 To -2 '-4=wdStyleHeading3, -2=wdStyleHeading1 Set aRng = ActiveDocument.Range With aRng.Find .ClearFormatting .Style = iHeadStyleID .Wrap = wdFindStop .Forward = True .Text = "" Do While .Execute aRng.ParagraphFormat.Reset aRng.Font.Reset Loop End With Next End Sub
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
|
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 |