Sub ReformatStatuteText()
' Turn Off Screen Updating
Application.ScreenUpdating = False
Dim TrkStatus As Boolean      ' Track Changes flag
With ActiveDocument
  ' Store current Track Changes status, then switch off
  TrkStatus = .TrackRevisions
  .TrackRevisions = False
  With .Styles("TOC 1")
    With .Font
      .Size = 11
      .Bold = True
      .Italic = False
      .ColorIndex = wdAuto
    End With
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
  End With
  With .Styles("TOC 2")
    With .Font
      .Size = 11
      .Bold = True
      .Italic = False
      .ColorIndex = wdAuto
    End With
    With .ParagraphFormat
      .KeepWithNext = False
      .KeepTogether = True
      .RightIndent = InchesToPoints(0.5)
      .LeftIndent = InchesToPoints(0.5)
      .FirstLineIndent = InchesToPoints(-0.5)
      .TabStops.Add Position:=InchesToPoints(6.5), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
    End With
  End With
  With .Styles("Heading 1")
    .Font.Bold = True
    With .ParagraphFormat
      .Alignment = wdAlignParagraphCenter
      .LineSpacingRule = wdLineSpaceSingle
    End With
  End With
  With .Styles("Heading 2").ParagraphFormat
    .SpaceBefore = 6
    .SpaceAfter = 6
    .LineSpacingRule = wdLineSpaceSingle
  End With
  With .Styles("Heading 3").ParagraphFormat
    .SpaceBefore = 6
    .SpaceAfter = 6
    .LineSpacingRule = wdLineSpaceSingle
  End With
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    'Delete tabs & spaces preceding paragraph breaks
    .Text = "[^t ]@^13"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    'Replace all double spaces with single spaces
    .Text = "[ ]{2,}"
    .Replacement.Text = " "
    .Execute Replace:=wdReplaceAll
    'Limit paragraph breaks and manual line breaks to one 'real' paragraph per set.
    .Text = "[^13^11]{1,}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    'Delete 'Acts' paragraphs
    .Text = "^13Acts [0-9]{4}*^13"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    'ReFormat 'Title' paras
    .Format = True
    .Text = "TITLE ([0-9]{1,})[. ](*^13)"
    .Replacement.Text = "Part \1 - \2"
    .Replacement.Style = "Heading 1"
    .Execute Replace:=wdReplaceAll
    .Text = "Part [0-9]{1,}[!^13]@^13"
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
    'ReFormat 'CHAPTER' paras
    .Text = "CHAPTER [0-9]{1,}. (*^13)"
    .Replacement.Text = "\1"
    .Replacement.Style = "Heading 2"
    .Execute Replace:=wdReplaceAll
    .Text = "[0-9]{1,}.[0-9]{1,}.[0-9]{1,}*^13"
    .Replacement.Text = "^&"
    .Replacement.Style = "Heading 2"
    .Execute Replace:=wdReplaceAll
    'ReFormat 'CHAPTER' paras
    .Format = False
    .Text = "(Art. [0-9.]{1,})([A-Z])"
    .Replacement.Text = "\1 \2"
    .Execute Replace:=wdReplaceAll
    .Text = "(Art. [0-9.]{1,} [!.]@.) ([!^13]*^13)"
    .Replacement.Text = "\1^p\2"
    .Execute Replace:=wdReplaceAll
    .Format = True
    .Text = "Art. [0-9.]{1,} [!.]@.^13"
    .Replacement.Text = "^&"
    .Replacement.Style = "Heading 3"
    .Execute Replace:=wdReplaceAll
  End With
  .TablesOfContents(1).Update
  ' Restore original Track Changes status
  .TrackRevisions = TrkStatus
End With
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub