Sub BodyLevel_Schedule()
  Dim aPara As Paragraph, iLev As Integer, iStart As Integer, sStyName As String
  Dim bBold As Boolean, aRng As Range
  
  Set aRng = Selection.Range
  If Selection.Type = wdSelectionIP Then
    MsgBox Prompt:="You have not selected any text!"
    Exit Sub
  ElseIf aRng.Paragraphs(1).OutlineLevel = wdOutlineLevelBodyText Then
    iLev = InputBox("What level heading precedes your selected text?", "Starts at Level", "1")
  End If
  
  For Each aPara In aRng.Paragraphs
    sStyName = Split(aPara.Style, ",")(0)   'removes aliases from stylename
    aPara.Range.Select
    Select Case True
      Case sStyName Like "Schedule Level *"           'keep track of the preceding Schedule Level
        iLev = aPara.OutlineLevel
        bBold = aPara.Range.Words(1).Font.Bold
      Case sStyName Like "Body*", sStyName Like "Normal"
        If iLev < 8 And aPara.Range.Characters.Count > 1 Then
          If bBold Then
            aPara.Style = "Body" & iLev
          Else
            aPara.Style = "Body" & iLev - 1
          End If
        End If
    End Select
  Next aPara
End Sub