Sub ApplyHeadingStyles_Auto1Works1()
Application.ScreenUpdating = False
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.Characters.First
      With Rng
        If .text Like "[0-9(]" Then
          .MoveEndUntil " ", wdForward
          If InStr(.text, vbTab) > 0 Then
            .Collapse wdCollapseStart
            .MoveEndUntil vbTab, wdForward
          End If
          StrTxt = .text: bLvl = False
          .End = .End + 1
          objUndo.StartCustomRecord ("Fmt")
          For i = 1 To 6
            .Style = "Heading " & i
            If .ListFormat.ListString = StrTxt Then
              .text = vbNullString: bLvl = True: Exit For
            End If
          Next
          objUndo.EndCustomRecord
          If bLvl = False Then ActiveDocument.Undo: DoEvents
        End If
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub