Sub DPU_ManualToSchedule_Sched1Bold()
Application.ScreenUpdating = False
Dim para As Paragraph, Rng As Range, iLvl As Long, i As Paragraph, n As Long, StyleName As String, wrd As Long, Count As Long
If Len(Selection.Range) = 0 Then
    MsgBox "Select the text first", vbCritical
Exit Sub
End If
With Selection.Range
For Each i In ActiveDocument.Paragraphs 'Remove all leading spaces e.g tabs, spaces, NBS
For n = 1 To i.Range.Characters.Count
If i.Range.Characters(1).Text = " " Or i.Range.Characters(1).Text = " " Or i.Range.Characters(1).Text = Chr(9) Or i.Range.Characters(1).Text = Chr(160) Then
i.Range.Characters(1).Delete
Else: Exit For
End If
Next n
Next
    For Each para In .Paragraphs
    If para.Range.Information(wdWithInTable) = False Then
      Set Rng = para.Range.Words.First 'Convert manual numbering to Schedule Level numbering
      With Rng
        If IsNumeric(.Text) Then
          While .Characters.Last.Next.Text Like "[0-9. " & vbTab & "]"
            .End = .End + 1
          Wend
          iLvl = UBound(Split(.Text, "."))
          If IsNumeric(Split(.Text, ".")(UBound(Split(.Text, ".")))) Then iLvl = iLvl + 1
          If iLvl < 10 Then
            .Text = vbNullString
            para.Style = "Schedule Level " & iLvl
           End If
        End If
      End With
    End If
  Next
End With
With Selection.Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Style = "Schedule Level 1" 'format Schedule Level 1 bold
        .Font.Bold = False
        .Text = ""
        .Replacement.Font.Bold = True
        .Replacement.Text = ""
        .Replacement.ParagraphFormat.KeepWithNext = True
        .Forward = True
        .Wrap = wdFindStop
        .Execute Replace:=wdReplaceAll
End With

   Application.ScreenUpdating = True
End Sub