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