When starting a new project I have found it very useful to develop a chapter-by-chapter word count for the manuscript: this lets me make sure my pace isn’t too fast or too slow and helps me develop a schedule for how many chapters per day I should cover. Developing this count by hand isn’t particularly efficient, so I recently decided to hunt down a macro to handle this work for me.

After a bit of online searching I found a macro posted by onesecondglance that did what I wanted. However it took a long time to analyze book-length Word documents, even after extensive rewriting. To replace it I developed new a macro using code by CuberChase as a starting point.

This macro queries the user for the name of the Word style applied to chapter headings (“Heading 1” is the default) and then counts words from the start of one heading to the start of the next. It also counts any words that appear before the first heading. It then creates a new word document and inserts into it the name of each chapter followed by that chapter’s word count. A tab character is inserted between each chapter name and word count so that the contents can be easily cut and pasted into an Excel spreadsheet.

As written the macro does have a few limitations, which I may get around to addressing if they present a problem:

• It considers anything formatted using the heading style to be a heading, including blank lines, so make sure that the style is only applied to actual headings.
• It does not count text in footnotes, endnotes or text boxes.
• It does not like hidden track changes in headings and has been written to display all revisions before running. Because of this it will extract both the original and revised heading text.

The Code

Sub Chapter_Word_Count()
'Based on code from: http://stackoverflow.com/questions/17218587/how-to-parse-ms-word-document-by-style-with-vba

	Dim iCount As Integer
	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

        With ActiveWindow.View.RevisionsFilter
            .Markup = wdRevisionsMarkupAll
            .View = wdRevisionsViewFinal
        End With

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

	'Collect name of style type
	sMyStyle = InputBox("What is the name of the Word style used for chapter headings?", "Count Chapter Words", "Heading 1")
	Application.ScreenUpdating = False

	'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 = wdFindContinue
		.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 = sMyStyle
		.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 3, 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
				iOffset = 1
			End If

			sArray(2, iCount + iOffset) = Selection.Text
			sArray(3, iCount + iOffset) = iParNum

			'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 3, 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
		Application.ScreenUpdating = True
		Documents.Add
		For ii = LBound(sArray, 2) To UBound(sArray, 2)
			Selection.Text = Left(sArray(2, ii), Len(sArray(2, ii)) - 1) & Chr(9) & sArray(1, ii) & Chr(10)
			Selection.MoveRight wdCharacter, 1
		Next ii
		'If no headings found, return alternate message
		Else
			MsgBox "This document does not use the style " & sMyStyle, vbExclamation + vbOKOnly, "Bad Style Name"
	End If
End Sub