Macro to count words in each heading in Microsoft Word

Count Word Macro.text

Sub CountHeadingSpanText()
Application.ScreenUpdating = False
Dim RngHd As Range, h As Long, strOut As String
' h = CLng(InputBox("Input the Heading level (e.g. 1) for the heading spans to count", "Heading Span Word Counter", 1))
' If (h < 1) Or (h > 9) Then Exit Sub
h = 1
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Style = "Heading " & h
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    Set RngHd = .Paragraphs(1).Range
    Set RngHd = RngHd.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    With RngHd
      strOut = strOut & .ComputeStatistics(wdStatisticWords) - .Paragraphs.First.Range.ComputeStatistics(wdStatisticWords) & vbTab & .Paragraphs.First.Range.Text
    End With
    .Start = RngHd.End
    .Find.Execute
  Loop
End With
Set RngHd = Nothing
MsgBox "The following word counts are associated with each level " & h & " heading:" & vbCr & strOut
Application.ScreenUpdating = True
End Sub