Do not add two spaces after Mr. or Ms.

[slaycock]

Try the following as a more sophisticated approach.

Sub FixTwoSpacesAfterPeriod(Optional ByVal FindRange As Range = Nothing)

Dim myAllowedWords As String
Dim myRange As Range
Dim myRangeCopy As Range
Dim myRangeEnd As Long

    ' The literal string below could be replaced by a reference to a custom document property
    ' Which makes the list editable by the user
    ' e.g. myOneSpaceWords = ActiveDocument.CustomDocumentProperties("OneSpaceWords")
    
    myOneSpaceWords = "Dr,Ms,Mr,Mrs,Messrs,Hon"
    
    ' Check the parameter and if it is 'Nothing' check for a selected range before using the 
    ' whole document main story range
    
    If FindRange Is Nothing Then
        If Selection.Range.End <> Selection.Range.Start Then
            Set myRangeCopy = Selection.Range
        Else
            Set myRangeCopy = ActiveDocument.StoryRanges(wdMainTextStory)
        Else
    Else
        Set myRangeCopy = FindRange
    End If
    
    ResetFindReplaceParameters
    
    ' First do an undconditional Find and Replace
    
    Set myRange = myRangeCopy
    With myRange.Find
        .Text = "([.\?\!]) {1,}"
        .Replacement.Text = "\1  "
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    
    ' Now remove the two spaces for the list of myOneSpaceWords
    ' The myrange.Select are included  to show the logic when stepping
    ' Through the code with F8.  They should be deleted for general use
    
    myRangeEnd = myRangeCopy.End
    With myRange.Find
        Do
            myRange.End = myRangeEnd
            myRange.Select
            .Text = "(?)(. {2,})"
            .MatchWildcards = True
            .Execute
            ' myRange is now the found text
            myRange.Select
            If .Found Then
                If InStr(myOneSpaceWords, myRange.Words.First) > 0 Then
                    ' delete the last space in the found text
                    myRange.Characters.Last.Delete
                    myRange.Select
                End If
            End If
            myRange.Collapse direction:=wdCollapseEnd
            myRange.Select
        Loop Until Not .Found
    End With
End Sub

Sub ResetFindReplaceParameters()

' The use of a range object is critical to the success of this macro
Dim myRange As Range
  
  Set myRange = ActiveDocument.StoryRanges(wdMainTextStory).Characters(1)
  With myRange.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop  '  This means stop when we get to the end of the range
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

If I were using the above code I would have to add a third search and replace because I have names of micro-organisms which are usually italicised e.g. E. Coli

In which case I would have .format=true, .find.font.italic=true and .replace.font.italic

I'd then call the ResetFindReplaceParameters before the fourth search.