Sub FormatVerses()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13Chapter [0-9]{1,3}^13"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    Set Rng = .Duplicate.Characters.Last
    Rng.End = ActiveDocument.Range.End
    With .Duplicate
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^13Chapter [0-9]{1,3}^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute
      End With
      If .Find.Found Then Rng.End = .Start
      With Rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .Text = "([! ^13])([0-9]{1,3})"
        .Replacement.Text = "\1 \2"
        .Execute Replace:=wdReplaceAll
        .Text = "([0-9]{1,3})[ " & Chr(160) & "]"
        .Replacement.Text = "\1"
        .Execute Replace:=wdReplaceAll
        .Text = "[0-9]{1,3}"
        .Replacement.Text = "^&" & Chr(160)
        .Format = True
        With .Replacement.Font
          .Bold = True
          .Superscript = True
        End With
        .Execute Replace:=wdReplaceAll
      End With
    End With
    .Find.Execute
  Loop
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub