How to get macro to ignore punctuation

I'm working with a large chunk of text, and trying to convert it all to just the first two letter (memorization work). Someone on reddit got me a good macro script, but it removes punctuation from the text.

Here's the original macro:

Sub ReplaceWithFirstTwoLetters()
   Dim rng As Range, words As Variant, word As Variant, replacedText As String
   If Selection.Type = wdSelectionNormal Then Set rng = Selection.Range Else Set rng = ActiveDocument.Content
   words = Split(rng.Text, " ")
   For Each word In words
      If Len(word) > 2 Then replacedText = replacedText & Left(word, 2) & " " Else replacedText = replacedText & word & " "
   Next word
   rng.Text = Trim(replacedText)
End Sub

Example:
Original -
When in the Course of human events it becomes necessary for one people to dissolve the political bands which have connected them with another, and to assume among the Powers of the earth, the separate and equal station to which the Laws of Nature and of Nature's God entitle them, a decent respect to the opinions of mankind requires that they should declare the causes which impel them to the separation.
What I want -
Wh in th Co of hu ev it be ne fo on pe to di th po ba wh ha co th wi an, an to as am th Po of th ea, th se an eq st to wh th La of Na an of Na Go en th, a de re to th op of ma re th th sh de th ca wh im th to th se.

What I got -
Wh in th Co of hu ev it be ne fo on pe to di th po ba wh ha co th wi an an to as am th Po of th ea th se an eq st to wh th La of Na an of Na Go en th a de re to th op of ma re th th sh de th ca wh im th to th se

This solution will only work for single-character punctuation immediately following a word. Add other punctuation characters that you want to keep to sPUNCTUATION_TO_KEEP. Code comments included for an explanation.

Sub ReplaceWithFirstTwoLetters()
    Const sPUNCTUATION_TO_KEEP As String = ",.;:!?" ' add other characters you want to keep
    Dim rng As Range, words As Variant, word As Variant, replacedText As String
    If Selection.Type = wdSelectionNormal Then
        Set rng = Selection.Range
    Else
        Set rng = ActiveDocument.Content
    End If
    ' handle multiple paragraphs
    words = Split(Replace(Replace(rng.Text, vbCr, " "), "  ", " "), " ")
    For Each word In words
        If Len(word) > 2 Then
            replacedText = replacedText & Left(word, 2)
            ' keep the punctuation, if present at the end of the word
            If InStr(1, sPUNCTUATION_TO_KEEP, Right$(word, 1), vbBinaryCompare) > 0 Then
                replacedText = replacedText & Right$(word, 1)
            End If
            ' now add the space after the letters
            replacedText = replacedText & " "
        Else
            replacedText = replacedText & word & " "
        End If
    Next word
    rng.Text = Trim(replacedText)
End Sub

Sub ReplaceWithFirstTwoLetters()
   Dim s As String
   Const PUNTS As String = ",.!?:"  'add any more you want
   Dim rng As Range, words As Variant, word As Variant, replacedText As String, punt As String
   
   If Selection.Type = wdSelectionNormal Then Set rng = Selection.Range Else Set rng = ActiveDocument.Content
   words = Split(Replace(Replace(rng.Text, vbCr, " "), vbLf, " "), " ")
   'IF YOU WANT TO KEEP CR & LF COMMENT THE PREVIUS LINE AND UNCOMMENT THE NEXT
   ' words = Split(rng.Text, " ")
   For Each word In words
      word = Trim(word)
      If word <> "" Then
         If Len(word) > 2 Then
            punt = Right(word, 1)
            word = Left(word, 2)
            If InStr(1, PUNTS, punt) > 0 Then
               word = word & punt
            End If
         End If
         replacedText = replacedText & word & " "
      End If
   Next word
   rng.Text = Trim(replacedText)
End Sub

This is my way to implement to ignore punctuation OP.

The full code is too large to be here, you can refer to TextForCtext/WordVBA
/punctuation.cls in my repo.
I hope you find it useful