Trying to insert a number after every 100 words, ignoring punctuation and other characters

glrothman · #1 06-29-2025, 07:45 AM

Hi...

I want to be able to place a number after every 100 words in a document. 100 after the first 100 words, 200 after the first 200 words, etc. Everything I've tried (with Copilot's help) inserts a number every 75-85 words, evidently including non-word characters.

Any wisdom you can offer either about achieving an accurate word count, or about achieving my overall aim, would be appreciated.

Here's the latest version, which was supposed to address the undercount by identifying only actually, but didn't.

TIA!

Code:

Sub InsertNumbersEveryHundredWords()
    Dim doc As Document
    Dim wordCount As Long
    Dim i As Long
    Dim counter As Long
    Dim rng As Range
    
    Set doc = ActiveDocument
    wordCount = 0
    counter = 100
    
    For i = 1 To doc.Words.Count
        If wordCount >= 30000 Then Exit For
        
        ' Check if the current item is a word
        If Trim(doc.Words(i)) <> "" And Not doc.Words(i).Text Like "[!A-Za-z0-9]" Then
            wordCount = wordCount + 1
        End If
        
        If wordCount Mod 100 = 0 Then
            Set rng = doc.Words(i).Duplicate
            rng.Collapse Direction:=wdCollapseEnd
            rng.Text = " " & counter
            counter = counter + 100
        End If
    Next i

End Sub

vivka · #2 06-29-2025, 10:50 AM

Hi! Try this:

Code:

Sub InsertNumbersEveryHundredWords()

Dim rng As range
Dim wdCount As Long
Dim i As Long
Dim counter As Long

    Set rng = ActiveDocument.range
    wdCount = 0
    
    For i = 1 To rng.Words.count
        Set wd = rng.Words(i)
        If Trim(wd) Like "[0-9A-Za-z]*" Then
            wdCount = wdCount + 1
            If wdCount >= 10000 Then Exit Sub
            If wdCount Mod 100 = 0 Then
                wd.InsertAfter " " & wdCount & " "
                i = i + 1
            End If
        End If
    Next i
End Sub

macropod · #3 06-29-2025, 05:37 PM

Anything you do that inserts the count into the document body will: (a) mess up the word count; (b) put the counter in the wrong place for each successive count; and (c) be a pain to update.

Try the following code, which inserts the counts as comments. If you edit the document and re-run the macro, the old comments it created will be deleted and a new set created.

Code:

Sub WordCountMarker()
Application.ScreenUpdating = False
Dim RngDoc As Range, RngCmt As Range, Interval As Long, i As Long
Interval = CInt(InputBox("What word frequency do you want to tag?", "Word Count Marker", 120))
With ActiveDocument
  If Interval < 2 Or Interval >= .ComputeStatistics(wdStatisticWords) Then GoTo Abort
  For i = .Comments.Count To 1 Step -1
    If .Comments(i).Range.Text Like "Word: [0-9]*" Then
      .Comments(i).Delete
    End If
  Next
  DoEvents
  Set RngDoc = .Range(0, 0)
  While RngDoc.ComputeStatistics(wdStatisticWords) < .ComputeStatistics(wdStatisticWords)
    With RngDoc
      .MoveEnd wdWord, Interval - .ComputeStatistics(wdStatisticWords) Mod Interval
      If .ComputeStatistics(wdStatisticWords) Mod Interval = 0 Then
        Set RngCmt = .Characters.Last
        .Comments.Add RngCmt, "Word: " & .ComputeStatistics(wdStatisticWords)
        .MoveEnd wdWord, Interval
        If i Mod 50 = 0 Then DoEvents
      End If
    End With
  Wend
  DoEvents
End With
Abort:
Set RngDoc = Nothing: Set RngCmt = Nothing
Application.ScreenUpdating = True
End Sub

Note: If the count interval falls within a field (e.g. Table of Contents, Index), that interval’s count is skipped, since the comment would be deleted anyway the next time the field is refreshed.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to insert certain words if the number of words than 20	laith93	Word VBA	6	10-28-2022 01:12 AM
Select and change font size of words by number of characters	knpaddac	Word VBA	3	03-15-2021 03:00 PM
Forumla to find all words over three characters	14spar15	Excel	8	10-02-2020 09:58 AM
How show characters instead words (status bar)	BrunoChirelli	Word	2	02-19-2015 12:03 PM
Color words ending with special characters	Singh_Edm	Word	2	01-20-2014 12:51 AM