Sub CountChapterWords()
    
    '2021-06-04
    '
    'Inspired by: http://absolutewrite.com/forums/showthread.php?244493-Offering-my-meagre-supply-of-Word-macros
    'Based in part on code by CuberChase: http://stackoverflow.com/questions/17218587/how-to-parse-ms-word-document-by-style-with-vba
    'Uses code for output content and formatting from the macro "ExtractCommentsToNewDoc" created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
    '
    'This macro uses the macro ClearFindAndReplaceParameters and this must be installed for it to run properly
    '
    'If text has been selected when the macro is run, its style name will be extracted as the style for the macro to use
    'the cursor is returned to the original position after running
    'Includes the unformatted page number for the chapter heading
    'adds [No Chapter Title] if the title is just a hard return character
    'Adds header data and formats the results
    'This macro replaces tabs in a chapter title with spaces in the final report

    Dim iCount As Integer
    Dim ii as Long
    Dim iArrayCount As Integer
    Dim bFound As Boolean
    Dim rParagraphs As Range
    Dim lCurPos As Long
    Dim iParNum As Integer
    Dim iOffset As Integer
    Dim rBody As Range
    Dim sMyStyle As String
    Dim sTitle As String
    Dim sStyle As String
    Dim iPage As Integer
    Dim oDoc As Document
    Dim oNewDoc As Document
    Dim rPosition As Range
    Const sDialogTitle As String = "Count Words by Chapter"
    
    'On Error GoTo Err_Msg
    
    'Collect name of style
    Set rPosition = Selection.Range
    If Selection.Type = wdSelectionIP Then
        sStyle = InputBox("What is the name of the style used for chapter headings?", sDialogTitle, "Heading 1")
        If sStyle = "" Then GoTo Macroend
        Else
            sStyle = Selection.Style.NameLocal
            If sStyle = "Normal" Then
                MsgBox "The style Normal (and other body text styles) should not be used with this macro.", vbExclamation, sDialogTitle
                GoTo Macroend
                ElseIf MsgBox("Run this macro using the style " & sStyle & " (the style applied to the current selection)?", vbYesNo + vbQuestion, sDialogTitle) <> vbYes Then
                    GoTo Macroend
            End If
    End If

    Application.ScreenUpdating = False

    Set oDoc = ActiveDocument
    'Initialize 100-entry array
    Dim sArray() As String
    iArrayCount = 100
    iOffset = 0
    ReDim sArray(1 To 4, 1 To iArrayCount)

    'Move to top of the document
    Selection.HomeKey Unit:=wdStory

    'Set search parameters and look for the first instance
    With Selection.Find
        .ClearFormatting
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
        .Style = sStyle
        .Execute
    End With

    'If found start loop to check for entries
    'counter added to avoid endless loops
    Do While Selection.Find.Found = True And iCount < 1000
        iCount = iCount + 1

        'Add results to array
        If Selection.Find.Found Then
            bFound = True
            
            lCurPos = ActiveDocument.Bookmarks("\EndOfSel").Start
            Set rParagraphs = ActiveDocument.Range(Start:=0, End:=lCurPos)
            iParNum = rParagraphs.Paragraphs.Count

            'Check array size and resize if necessary
            If ii Mod iArrayCount = 0 Then ReDim Preserve sArray(1 To 4, 1 To UBound(sArray, 1) + iArrayCount)
            
            'add an initial entry if doc doesn't start with a heading
            If iCount = 1 And iParNum > 1 Then
                sArray(2, iCount) = "[Before first heading] "
                sArray(3, iCount) = 1
                sArray(4, iCount) = 1
                iOffset = 1
                iPage = 1
            End If
            
            sTitle = Selection.Text
            sTitle = Replace(sTitle, Chr(9), " ")
            If sTitle = Chr(13) Then
                sArray(2, iCount + iOffset) = "[No chapter title] "
                Else
                    sArray(2, iCount + iOffset) = sTitle
            End If
            sArray(3, iCount + iOffset) = iParNum
            sArray(4, iCount + iOffset) = Selection.Information(wdActiveEndPageNumber)
            
            'Reset the find parameters
            Selection.Find.Execute
        End If
    Loop
    
    If bFound Then
        'Finalise the array to the actual size
        ReDim Preserve sArray(1 To 4, 1 To iCount + iOffset)

        'Calculate chapter lengths, including length of chapter heading
        For ii = LBound(sArray, 2) To UBound(sArray, 2) - 1
            'Select range of paragraphs to measure
            Set rBody = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(CInt(sArray(3, ii))).Range.Start, _
            End:=ActiveDocument.Paragraphs(CInt(sArray(3, ii + 1)) - 1).Range.End)
            sArray(1, ii) = rBody.ComputeStatistics(wdStatisticWords)
        Next ii
            Set rBody = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(CInt(sArray(3, UBound(sArray, 2)))).Range.Start, _
            End:=ActiveDocument.Bookmarks("\EndOfDoc").Range.End)
            sArray(1, UBound(sArray, 2)) = rBody.ComputeStatistics(wdStatisticWords)
            
        'Output results to a new document
        Set oNewDoc = Documents.add
        
        'add styling here
        oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
        "Chapter word counts extracted from: " & oDoc.FullName & vbCr & _
        "Created by: " & Application.UserName & vbCr & _
        "Creation date: " & Format(Date, "MMMM d, yyyy")
        
        'Adjust the Normal style and Header style
        With oNewDoc.Styles(wdStyleNormal)
            .Font.Name = "Arial"
            .Font.size = 10
            .ParagraphFormat.LeftIndent = 0
            .ParagraphFormat.SpaceAfter = 6
            .ParagraphFormat.TabStops.ClearAll
            .ParagraphFormat.TabStops.add Position:=InchesToPoints(3), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces
            .ParagraphFormat.TabStops.add Position:=InchesToPoints(4), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces
        End With
        With oNewDoc.Styles(wdStyleHeader)
            .Font.size = 8
            .ParagraphFormat.SpaceAfter = 3
        End With
        Selection.PageSetup.TopMargin = InchesToPoints(1.5)
        Selection.Text = "Chapter Name" & Chr(9) & "Starting Page" & Chr(9) & "Word Count" & Chr(10)
        Selection.Style = wdStyleStrong
        Selection.MoveRight wdCharacter, 1
        
        For ii = LBound(sArray, 2) To UBound(sArray, 2)
            Selection.Text = Left$(sArray(2, ii), Len(sArray(2, ii)) - 1) & Chr(9) & sArray(4, ii) & Chr(9) & sArray(1, ii) & Chr(10)
            Selection.MoveRight wdCharacter, 1
        Next ii
        Else
            MsgBox "This document does not use the style " & sStyle, vbExclamation + vbOKOnly, sDialogTitle
    End If
    Call ClearFindAndReplaceParameters
    
Macroend:
    rPosition.Select
    If Not oNewDoc Is Nothing Then
        oNewDoc.Activate
        Selection.HomeKey Unit:=wdStory
    End If
    Application.ScreenUpdating = True
    Exit Sub

Err_Msg:
    Application.ScreenUpdating = True
    Call ClearFindAndReplaceParameters
    MsgBox "The macro has encountered an error." & vbCrLf & Err.Number & ": " & Err.description, vbCritical, sDialogTitle
    rPosition.Select

End Sub

Private Sub ClearFindAndReplaceParameters()

    'from https://wordmvp.com/FAQs/MacrosVBA/ClearFind.htm
    'can be run from any search to reset the search parameters

    With Selection.Find
       .ClearFormatting
       .Replacement.ClearFormatting
       .Text = ""
       .Replacement.Text = ""
       .Forward = True
       .Wrap = wdFindStop
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
    End With

End Sub