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