Sub DeleteHeadings()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Content.Find
  .ClearFormatting
  .Format = True
  .Text = "^12"
  .Replacement.Text = "^&"
  .Replacement.Style = wdStyleNormal
  .Wrap = wdFindContinue
  .Replacement.ClearFormatting
  .Text = ""
  .Replacement.Text = ""
  For i = 1 To 9
    .Style = "Heading " & i
    .Execute Replace:=wdReplaceAll
  Next i
End With
Application.ScreenUpdating = True
End Sub