Try the following as a more sophisticated approach.
Code:
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.