This approach works much faster. Again, in the .Replacement.Text = "! " the extra space after the punctuation is being removed for some reason. Add the extra space in all 3 instances


Sub DoubleSpaceToEndSentence2()
Dim Word As range
Dim WordCollection(7) As String
Dim Words As Variant
Selection.WholeStory
With Selection
.Font.Color = Default
End With
WordCollection(0) = "Mr. "
WordCollection(1) = "Mrs. "
WordCollection(2) = "Dr. "
WordCollection(3) = "Ms. "
WordCollection(4) = "Mt. "
WordCollection(5) = "etc. "
WordCollection(6) = "ETC. "
WordCollection(7) = "[0-9].[0-9]"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Color = vbBlue
For Each Words In WordCollection
With Selection.Find
.Text = Words
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Selection.WholeStory
With Selection.Find
Selection.Find.ClearFormatting
Selection.Find.Font.Color = Default
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Color = Default
With Selection.Find
.Wrap = wdFindContinue
.MatchWildcards = False
.Text = ". "
.Replacement.Text = ". "
.Execute Replace:=wdReplaceAll
.Text = "! "
.Replacement.Text = "! "
.Execute Replace:=wdReplaceAll
.Text = "? "
.Replacement.Text = "? "
.Execute Replace:=wdReplaceAll
End With
Selection.WholeStory
With Selection
.Font.Color = Default
End With
End With
End Sub