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.
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