Counting Words by Chapter

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:

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

	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, _
			sArray(1, UBound(sArray, 2)) = rBody.ComputeStatistics(wdStatisticWords)

		'Output results to a new document
		Application.ScreenUpdating = True
		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
			MsgBox "This document does not use the style " & sMyStyle, vbExclamation + vbOKOnly, "Bad Style Name"
	End If
End Sub


An Inline Commenting Macro

Inline comments—that is, comments inserted within the body of a document—can be a very useful alternative to Word’s built-in Comments tool (in a previous post I discuss their pros and cons). However, formatting them so that they stand out from the text requires a few extra keystrokes for each comment.

To make formatting less labor intensive, I cooked up a short macro (presented below) that automates the process. Its operation is very simple. If the user types a comment, selects it, and runs the macro, the comment will be reformatted: braces will be placed on either end of the comment, and the braces and comment will have the built-in Word style Strong applied to them. If the macro is run without any text being selected, a set of braces will be inserted, the Strong style will be applied to them, and the cursor placed between the braces, allowing a comment to be easily entered. For the macro to really save you work, you will need to assign it a keyboard shortcut (I use Ctrl+Alt+q).

Using a Word style allows all comments to be quickly reformatted by changing the definition of the style. It also allows all comments to be quickly selected using the Select All option in the Styles toolbar; this can be handy if you want to quickly delete or copy all comments. The macro’s use of the predefined Strong style can be a problem if you are using that style for other content in your document, but this can be fixed by changing the name of the style referenced in the macro. Since the macro applies one style to all comments, color-coding isn’t supported. However, if you prefer to color-code comments, one option is to replace the line in the macro stating

Selection.Range.Style = wdStyleStrong


Selection.Range.HighlightColorIndex = Options.DefaultHighlightColorIndex

to apply the current highlighting color, rather than a text style, to each inline comment as it is created.

Note: While poking around on the internet recently, I came across a similar but more elaborate set of macros, created by Professor Benjamin L. Read, for working with inline notes. If you are interested in color-coding your notes, his macros might be useful to try out.


The Code

Sub InsertInlineComment()
'Written by Michael Schuler, 2014.
'Recommended shortcut: CTRL+ALT+q
    Set myRange = Selection
    myRange.InsertBefore " {"
    myRange.InsertAfter "} "
    Selection.Range.Style = wdStyleStrong
    Selection.MoveLeft Count:=1
    Selection.MoveRight Count:=2
End Sub


Automating a Style Sheet (Part 2)

As mentioned in Automating a Style Sheet, Part 1, I recently came across the StyleThat macro, which facilitates copying of terms from a manuscript to a style sheet. It seemed pretty useful but had a few weak points, so I made some adjustments to its code to try to fix things.

A useful feature that I didn’t add, but would have liked to, would alphabetize terms as they are inserted. Integrating a sorting function into the macro could be done, but would slow the process down a bit down. Instead, I created a stand-alone macro that sorts all of the terms in the style sheet at the same time. This allows one to alphabetize the content as often as desired.

This macro (shown below) works by finding content between adjacent headings, or between a heading and the end of the document, and then sorting these entries into alphabetical order. For this to work properly all headings used to organize terms need to use a custom style named Style Sheet Heading. Since it finds headings based on their style name rather than their content, this macro can be used to sort material organized using categories different from those required by the StyleThat macro (for example, it will sort content organized using the headings “people” and “places”). The Style Sheet Heading style can have any appearance you want; the macro only cares about its name.

When sorting, the macro will ignore trailing spaces or line returns, but blank lines within a set of terms will get sorted to the top of the list, so it is best to avoid including these.

Operation of the macro is simple: just make your style sheet the active Word document and run the macro. I have found it handy to run the macro fairly regularly, and recommend assigning a keyboard shortcut to it.

If you find this macro useful, if you have problems with it, or if you have suggestions for improvements, please let me know.

The Code


Sub SortStyleSheet()
'Recommended shortcut: ALT+1
Dim i As Paragraph
Dim sortrange As Range
flag = 0
'flag value: 0=no heading yet located; 1=heading located; 2=entries to sort located
Selection.Collapse Direction:=wdCollapseEnd
  For Each i In ActiveDocument.Paragraphs
        If i.Style.NameLocal = "Style Sheet Heading" Then
            If flag = 2 Then
            While (Asc(Selection.Characters.Last) = 13) Or (Asc(Selection.Characters.Last) = 32)
                Selection.MoveEnd Unit:=wdCharacter, Count:=-1
                 If Len(Trim(Selection.Text)) > 1 Then Selection.Sort SortOrder:=wdSortOrderAscending
                 flag = 1
                 flag = 1
            End If
           If flag = 1 Then
              Set sortrange = i.Range
              flag = 2
              If flag = 2 Then
                 Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
              End If
           End If
        End If
    While (Asc(Selection.Characters.Last) = 13) Or (Asc(Selection.Characters.Last) = 32)
           Selection.MoveEnd Unit:=wdCharacter, Count:=-1
    If flag = 2 Then
        If Len(Trim(Selection.Text)) > 1 Then Selection.Sort SortOrder:=wdSortOrderAscending
    End If
 End Sub

Automating a Style Sheet (Part 1)

I recently came across the StyleThat macro, which facilitates quickly copying terms from a manuscript to a style sheet. It is incredibly useful, in that it not only copies selected terms but also places them into alphabetical categories. However, after playing with it for a while I noticed that it had a few weak points. My version of the macro (appearing at the bottom of this post) tries to address the following weaknesses in the original through some judicious code tweaking.

1) When the original macro pasted content, it retained its original format.  I added code that removes all formatting, assuming that it is easier to manually reformat a few entries (such as titles of works) than it is to manually unformat a large number of entries.

2) If the selected text includes a trailing line break or space, the original macro included these characters in the pasted entry. To help keep style sheet content clean, I added code to delete any trailing hard returns and spaces.

3) The original macro only worked with style sheets that contain specific headings (described below), which are defined within the macro. I added code to place copied content at the bottom of the style sheet if one of these headings can’t be found (or if the style sheet doesn’t contain any headings). This allows use of a blank word document as a style sheet.

4) The original only works correctly if two documents are open: the manuscript and the style sheet.  While this limitation remains in my version, I added code to notify the user if the macro is run while more than or less than two documents are open.

5) The original macro places all entries that don’t start with a letter under a “Comments:” heading. I adjusted the name of this heading to “Numbers/Other” to more clearly describe its content.

One remaining weakness of the macro that it doesn’t sort entries within each category into alphabetical order. However, in Automating your Style Sheet, Part 2 I provide a stand-alone macro that takes care of this.

Using the macro is very simple, particularly if a keyboard shortcut is assigned to it:

1) Open the manuscript and a style sheet that contains the following headings: ABCD, EFGH, IJLK, MNOP, QRST, UVWXYZ, and Numbers/Other.

2) Select a term in the manuscript and run the macro. It will switch focus from the manuscript to the style sheet and paste the term under the appropriate heading (or at the end of the document if no matching heading is found).

3) Run the macro again and it will switch focus back to the manuscript (this feature is very handy if a keyboard shortcut is assigned).

 I would like to thank Jack Lyon at The Editorium for permission to revise his original StyleThat macro. If you find either version particularly useful, please feel free to let us know.

The Code

Sub StyleThatV2()
'Macro adapted by Hilary Powers 1/30/04; updated 4/6/04
'Adapted by Jack M. Lyon for use with editorial style sheet
'Adapted by Michael Schuler 6/4/2015 to expand functions
'Recommended shortcut: ALT+`
iNumWindows = Application.Windows.Count
If iNumWindows <> 2 Then
    MsgBox ("This macro only works if two documents (the source document and the stylesheet) are open.")
    GoTo Final
End If

If Selection.Type = wdSelectionIP Then  'No selection
    GoTo HedBack
    While (Asc(Selection.Characters.Last) = 13) Or (Asc(Selection.Characters.Last) = 32)
        Selection.MoveEnd Unit:=wdCharacter, Count:=-1
        If Selection.Type = wdSelectionIP Then GoTo Final
    FirstChar = Asc(Selection.Characters.First)
    If FirstChar > 64 And FirstChar < 69 Then MySearch = "ABCD^p"
    If FirstChar > 68 And FirstChar < 73 Then MySearch = "EFGH^p"
    If FirstChar > 72 And FirstChar < 77 Then MySearch = "IJKL^p"
    If FirstChar > 76 And FirstChar < 81 Then MySearch = "MNOP^p"
    If FirstChar > 80 And FirstChar < 85 Then MySearch = "QRST^p"
    If FirstChar > 84 And FirstChar < 91 Then MySearch = "UVWXYZ^p"
    If FirstChar > 96 And FirstChar < 101 Then MySearch = "ABCD^p"
    If FirstChar > 100 And FirstChar < 105 Then MySearch = "EFGH^p"
    If FirstChar > 104 And FirstChar < 109 Then MySearch = "IJKL^p"
    If FirstChar > 108 And FirstChar < 113 Then MySearch = "MNOP^p"
    If FirstChar > 112 And FirstChar < 117 Then MySearch = "QRST^p"
    If FirstChar > 116 And FirstChar < 123 Then MySearch = "UVWXYZ^p"
    If FirstChar > 90 And FirstChar < 97 Then MySearch = "Numbers/Other^p"
    If FirstChar < 65 Or FirstChar > 122 Then MySearch = "Numbers/Other^p"
    With Selection.Find
        .Text = MySearch
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    If Selection.Find.Execute Then
        Selection.EndKey Unit:=wdStory
    End If
    Selection.MoveLeft Count:=1
    Selection.HomeKey Unit:=wdLine
    Selection.MoveEnd Unit:=wdLine
    With Selection
    End With
    Selection.Collapse Direction:=wdCollapseEnd
    GoTo Final
End If
Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub