Try:
Sub FormatCapsStringToEmphasis()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long
With ActiveDocument
Set Rng = .Range(0, 0)
Set Rng = Rng.GoTo(What:=wdGoToPage, Name:=4)
Rng.End = .Range.End
With Rng
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[A-Z][A-Z '\!\?.,:;]{2,}"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWildcards = True
End With
Do While .Find.Execute
If .Paragraphs.Count > 1 Then .End = .Paragraphs.First.Range.End
If .End = .Paragraphs.First.Range.End Then .End = .End - 1
.MoveEndWhile "[ \!\?.,:;]", wdBackward
If .Characters.Last.Next Like "[a-z]" Then .End = .End - 1
.MoveEndWhile "[ \!\?.,:;]", wdBackward: i = 0
Select Case Split(.Text, " ")(UBound(Split(.Text, " ")))
Case "I", "A", "OK", "O.K", "ADD", "A.D.D", "ADHD", "A.D.H.D", "UFO", "U.F.O", "US", "U.S", "USA", "U.S.A"
i = Len(Split(.Text, " ")(UBound(Split(.Text, " ")))) + 1
.End = .End - i
End Select
If Len(.Text) > 1 Then
.Style = wdStyleEmphasis
.HighlightColorIndex = wdPink
.Case = wdTitleSentence
If .Characters.First.Previous Like "[""" & vbCr & Chr(11) & "]" Then .Words.First.Case = wdTitleWord
Select Case LCase(Split(.Text, " ")(UBound(Split(.Text, " "))))
Case "alabama", "ohio"
.Words.Last.Case = wdTitleWord
End Select
End If
.End = .End + i
.Collapse wdCollapseEnd
Loop
End With
End With
Application.ScreenUpdating = True
End Sub