Word counting macro for newly added portion?

New Daddy · #1 01-07-2012, 02:46 PM

I'd like to build a habit of writing at least a certain number of words per day. If I turn on the tracking, I can distinguish the newly added parts from the previous draft. Is it possible to count the words within such new addition using macro?

macropod · #2 01-07-2012, 11:35 PM

Hi New Daddy,

You could use a macro like:

Code:

Sub WordCounter()
Dim oRev As Revision, i As Long
For Each oRev In ActiveDocument.Revisions
  If Int(oRev.Date) = Date And oRev.Type = wdRevisionInsert Then
    i = i + oRev.Range.ComputeStatistics(wdStatisticWords)
  End If
Next
MsgBox i & " words added today.", vbInformation
End Sub

Note that this only counts words in the body of the document - not anything in textboxes, headers, footers, etc.

New Daddy · #3 01-08-2012, 06:58 AM

This is great stuff! Works just as I wished too. Thanks!

New Daddy · #4 01-25-2012, 10:41 PM

Is there a way to make this macro count revisions in the footnotes as well?
I've been trying to combine .Footnotes and .Revisions with ActiveDocument, but it doesn't seem to work.

macropod · #5 01-26-2012, 01:16 AM

Quote:

Originally Posted by New Daddy

Is there a way to make this macro count revisions in the footnotes as well?
I've been trying to combine .Footnotes and .Revisions with ActiveDocument, but it doesn't seem to work.

Hi New Daddy,

Yes, the macro's scope can be expanded, but I'd rather not do it piecemeal:

Code:

Sub WordsForToday()
Application.ScreenUpdating = False
Dim Sctn As Section, oHdFt As HeaderFooter, lHdr As Long, lFtr As Long
Dim oEnt As Endnote, lEnt As Long, oFnt As Footnote, lFnt As Long
Dim oShp As Shape, lShp As Long
With ActiveDocument
  For Each oEnt In .Endnotes
    lEnt = lEnt + CountRevisions(oEnt.Range)
  Next
  For Each oFnt In .Footnotes
    lFnt = lFnt + CountRevisions(oFnt.Range)
  Next
  For Each Sctn In .Sections
    For Each oHdFt In Sctn.Headers
      If Not oHdFt.LinkToPrevious Then _
        lHdr = lHdr + CountRevisions(oHdFt.Range)
    Next
    For Each oHdFt In Sctn.Footers
      If Not oHdFt.LinkToPrevious Then _
        lFtr = lFtr + CountRevisions(oHdFt.Range)
    Next
  Next
  For Each oShp In .Shapes
    If Not oShp.TextFrame Is Nothing Then _
      lShp = lShp + CountRevisions(oShp.TextFrame.TextRange)
  Next
  MsgBox "Today's Word Count Statistics:" & vbCr & _
    "EndNotes - " & vbTab & lEnt & vbCr & _
    "Footnotes - " & vbTab & lFnt & vbCr & _
    "Headers - " & vbTab & vbTab & lHdr & vbCr & _
    "Footers - " & vbTab & vbTab & lFtr & vbCr & _
    "Shapes - " & vbTab & vbTab & lShp & vbCr & _
    "Other - " & vbTab & vbTab & CountRevisions(.Range)
End With
Application.ScreenUpdating = True
End Sub
 
Function CountRevisions(Rng As Range) As Long
Dim oRev As Revision, i As Long
For Each oRev In Rng.Revisions
  If Int(oRev.Date) = Date And oRev.Type = wdRevisionInsert Then
    i = i + oRev.Range.ComputeStatistics(wdStatisticWords)
  End If
Next
CountRevisions = i
End Function

New Daddy · #6 01-26-2012, 09:56 AM

Quote:

Originally Posted by macropod

Hi New Daddy,

Yes, the macro's scope can be expanded, but I'd rather not do it piecemeal:

This is beautiful!
Thanks!

New Daddy · #7 11-26-2012, 11:07 PM

It's been a while and I've been an ardent user of this macro.
But I just found that the footnote part under-counts the new words added. I counted manually to make sure, and there is a substantial under-counting.

Any idea why this is happening?

macropod · #8 11-26-2012, 11:46 PM

I've retested and an unable to generate an erroneous count.
Can you attach a document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab.

New Daddy · #9 11-27-2012, 10:33 AM

Quote:

Originally Posted by macropod

I've retested and an unable to generate an erroneous count.
Can you attach a document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab.

Is there any chance that this same macro can behave differently in Word 2003 than in Word 2007 and later? The footnotes are fully counted in Word 2007 at work.

In any event, attached is a little sample whose tracked footnotes are not counted when the macro is run in Word 2003 but are counted in Word 2007.

macropod · #10 11-27-2012, 02:52 PM

Try changing the Function to:

Code:

Function CountRevisions(Rng As Range) As Long
Dim i As Long, j As Long
With Rng
  For i = 1 To .Revisions.Count
    If .Revisions(i).Type = wdRevisionInsert Then
      j = j + .Revisions(i).Range.ComputeStatistics(wdStatisticWords)
    End If
  Next
End With
CountRevisions = j
End Function

New Daddy · #11 11-27-2012, 09:09 PM

It's perfectly working now! Thanks!

New Daddy · #12 11-29-2012, 11:16 PM

In an attempt to be honest about my daily work progress, I added a couple of lines to the CountRevisions function so that it can subtract the number of words deleted, to give the total the net words added. But it doesn't work. It doesn't seem to be subtracting the number of words deleted.

Any idea why not? Could this be another Word 2003 issue?

Code:

Function CountRevisions(Rng As Range) As Long
Dim oRev As revision, i As Long, j As Long

With Rng
  For i = 1 To .Revisions.Count
    If .Revisions(i).Type = wdRevisionInsert Then
      j = j + .Revisions(i).Range.ComputeStatistics(wdStatisticWords)
    End If
    If .Revisions(i).Type = wdRevisionDelete Then
      j = j - .Revisions(i).Range.ComputeStatistics(wdStatisticWords)
    End If
  Next
End With

CountRevisions = j
End Function

macropod · #13 11-30-2012, 12:10 AM

Hi New Daddy,

It's nothing to do with Word 2003. Rather, it's that ComputeStatistics(wdStatisticWords) doesn't count text marked as deleted. Here's a workaround:

Code:

Function CountRevisions(Rng As Range) As Long
Dim i As Long, j As Long, Str As String
With Rng
  For i = 1 To .Revisions.Count
    If .Revisions(i).Type = wdRevisionInsert Then
      j = j + .Revisions(i).Range.ComputeStatistics(wdStatisticWords)
    ElseIf .Revisions(i).Type = wdRevisionDelete Then
      Str = Trim(.Revisions(i).Range.Text)
      Str = Replace(Str, vbCr, " ")
      While InStr(Str, "  ") > 0
        Str = Replace(Str, "  ", " ")
      Wend
      j = j - (UBound(Split(Str, " ")) + 1)
    End If
  Next
End With
CountRevisions = j
End Function

New Daddy · #14 12-09-2012, 04:49 PM

Quote:

Originally Posted by macropod

It's nothing to do with Word 2003. Rather, it's that ComputeStatistics(wdStatisticWords) doesn't count text marked as deleted. Here's a workaround:

This new code worked fine and exactly as it was supposed to. Thank you very much.

But recently, it started to cause an '5852 run-time error', where the following code kicks in. This is really strange, because it was fine a few days ago. Any idea why?

If .Revisions(i).Type = wdRevisionInsert Then

macropod · #15 12-09-2012, 05:31 PM

I'm not aware of anything in the code that could account for that. Perhaps re-starting Word (or even Windows) will resolve the problem. If not, try repairing the Office installation (via Help|Detect & Repair for Word 2003 & via Programs & Features > Microsoft Office > Change in the Windows Control Panel for Word 2010).

PS: There's no need to quote each previous post in its entirety every time you make a reply. Quote only when you need to and only those parts warranting it.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Counting Colors	g48dd	Excel	2	03-13-2011 09:28 PM
Added letters to body message	kawzie	Outlook	1	07-12-2010 11:00 AM
Half hour added between tasks	maruchi	Project	1	06-17-2010 08:06 AM
Form field to automatically be added to header?	razberri	Word VBA	3	02-22-2010 03:48 PM
Help! All Messages in Web Email deleted when account added to Outlook	UrbanEast	Outlook	2	07-17-2009 09:32 PM