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