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
      .Collapse wdCollapseEnd
      If (ActiveDocument.Range.End - .End) < 2 Then Exit Do
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub