literate through each word in the document and replace it with first letter of the word

Question

I am writing a macro which would keep only the initials of all the words in a document by keeping all the spaces between these words and keeping the special characters of the text.

The code is as follows

Sub rewrite_document_with_Initials()
Set myRange = ActiveDocument.Range
Dim w As String

For Each aWord In myRange.Words
w = aWord
If IsAlphabet(w) = True Then

 aWord.Select
Set A = Selection.Range
A = Left(aWord, 1)
Selection.TypeText A & " "
Else
Debug.Print aWord

 End If
 
Next aWord
End Sub
Function IsAlphabet(inpChar As String) As Boolean
    Dim chkChar As String
    
    'Convert the character to Uppercase.
    'So that there is no need to do a check for Lower and Uppercase seperately.
    chkChar = UCase(inpChar)
    
    'Check whether input character is Alphabet or not
    IsAlphabet = Asc(chkChar) > 64 And Asc(chkChar) < 91
End Function

in above code it illiterate through each word in document and check if it is contains alphabets

-if yes then it replace it with first letter.

But the problem is, it stuck at the first word don't know if I am making correct range or string?

if there is shortest method of doing so please suggest!

Answer 1

Try this procedure with regular expressions. Instead of each word, it loops through each paragraph and hence, it will work faster.

Sub rewrite_document_with_Initials()
Dim regex As Object
Dim mColl As Object

Set regex = CreateObject("VBScript.RegExp")        
regex.Global = True
regex.IgnoreCase = True
regex.Pattern = "\B[A-Za-z]+"
'I missed special characters earlier
For i = 1 To ThisDocument.Paragraphs.Count
    ThisDocument.Paragraphs(i).Range.Text = _
        regex.Replace(ThisDocument.Paragraphs(i).Range.Text, "")
Next i
End Sub