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