Sub ApplyHeadingStyles_Auto()
Dim Para As Paragraph, Rng As Range, i As Long, StrTxt As String, bLvl As Boolean
Dim objUndo As UndoRecord: Set objUndo = Application.UndoRecord
With ActiveDocument.Range
  For Each Para In .Paragraphs
    With Para
      Set Rng = .Range
      With Rng
        .Collapse wdCollapseStart
        .MoveEndUntil " ", wdForward
        If InStr(.Text, vbTab) > 0 Then
          .Collapse wdCollapseStart
          .MoveEndUntil vbtab, wdForward
        End If
         StrTxt = .Text: bLvl = False
         .End = .End + 1
      End With
      objUndo.StartCustomRecord ("Fmt")
      For i = 1 To 6
        .Style = "Heading " & i
        If .Range.ListFormat.ListString = StrTxt Then
         Rng.Text = vbNullString
          bLvl = True: Exit For
        End If
      Next
      objUndo.EndCustomRecord
      If bLvl = False Then ActiveDocument.Undo
    End With
  Next
End With
End Sub