Sub ertert()
If Selection.Type <> 1 Then
     MsgBox "Просто установите курсор внутри абзаца, который хотите преобразовать", 64
     Exit Sub
End If
Dim i&
With Selection
     .StartOf Unit:=wdParagraph, Extend:=wdMove
     .Expand wdSentence
     If .Characters.Count > 10 Then Exit Sub
End With
i = Len(Selection) - Len(Replace(Selection, ".", ""))
Selection.Delete
Selection.Expand wdParagraph
Select Case i
     Case 1
         Selection.Style = ActiveDocument.Styles("Подзаголовок")
     Case 2
         Selection.Style = ActiveDocument.Styles("Выделение")
     Case 3
         Selection.Style = ActiveDocument.Styles("Сильное выделение")
End Select
End Sub

Sub reNumber()
'
'проверка отсутствие выделения
If Selection.Type <> 1 Then
     MsgBox "Просто установите курсор внутри абзаца, который хотите преобразовать", 64
     Exit Sub
End If
'
'проверка наличия нужных стилей (чтобы не было ошибки применения)
Dim p As Style, MyStyleIs As Boolean
      
MyStyleIs = False
For i = 1 To ActiveDocument.Styles.Count ' так почему-то быстрее, чем с конца
     Set p = ActiveDocument.Styles(i)
     If Left$(p.NameLocal, 1) = "." Then
         MyStyleIs = True
         Exit For
     End If
Next i
If Not MyStyleIs Then LoadTemplate ' загрузка стилей, если они не нашлись
'
' если уже есть нумерация многоуровневыми стилями
If Selection.Range.ListFormat.ListType = wdListOutlineNumbering Then
     Lev = Selection.Range.ListFormat.ListLevelNumber
     Selection.Expand wdParagraph
     Select Case Lev
       Case 1
         Selection.Style = ActiveDocument.Styles(".Раздел 1")
       Case 2
         Selection.Style = ActiveDocument.Styles(".Раздел 2")
       Case 3
         Selection.Style = ActiveDocument.Styles(".Раздел 3")
     End Select
     Selection.Collapse
     Selection.MoveDown Unit:=wdParagraph, Count:=1
     Exit Sub
End If
'
' если обычный текст с/без нумерации в начале абзаца вручную
Dim ch As String, Flag_Number As Boolean, Count_Level, Count_Simbol As Integer, r

Flag_Number = False
Count_Level = 0
Count_Simbol = 0

With Selection
     .StartOf Unit:=wdParagraph, Extend:=wdMove
     .Expand wdParagraph
     n = .Characters.Count
      
     For i = 1 To n
      
         ch = .Characters(i)
         If (ch Like "[!0-9. ]") And (ch <> Chr(9)) Then Exit For
         Count_Simbol = Count_Simbol + 1
      
         If ch Like "[0-9]" Then
             If Flag_Number = False Then
                 Flag_Number = True
                 Count_Level = Count_Level + 1
                 'Next '// в начало цикла
             End If
         ElseIf ch = "." Then
             Flag_Number = False
         End If
      
     Next i
    
End With

Selection.End = Selection.Start + Count_Simbol
If Count_Simbol > 0 Then Selection.Delete
Selection.Expand wdParagraph
Select Case Count_Level
     Case 0
         Selection.Style = ActiveDocument.Styles(".стандартный")
     Case 1
         Selection.Style = ActiveDocument.Styles(".Раздел 1")
     Case 2
         Selection.Style = ActiveDocument.Styles(".Раздел 2")
     Case 3
         Selection.Style = ActiveDocument.Styles(".Раздел 3")
End Select
'Selection.Collapse
Selection.MoveDown Unit:=wdParagraph, Count:=1 ' автоматически переходим к следующему абзацу (чтобы не надо было жать Ctrl+СтрелкаВниз)
End Sub