What a merry go-round this has been! Try:
Code:
Sub TrueTitleCase(Rng As Range)
Dim RngTxt As Range, ArrTxt(), i As Long, j As Long
'list the exceptions to look for in an array
ArrTxt = Array("A", "An", "And", "As", "At", "But", "By", _
"For", "If", "In", "Of", "On", "Or", "The", "To", "With")
With Rng
For i = 1 To .Sentences.Count
Set RngTxt = .Sentences(i)
With RngTxt
.End = .End - 1
If .Information(wdWithInTable) And .Start = .End Then
.MoveStart wdCell, -1
.End = .End - 1
End If
.MoveStart wdWord
With .Duplicate
For j = LBound(ArrTxt) To UBound(ArrTxt)
With .Find
'replace items in the list
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Format = False
.Replacement.Text = ""
.Text = ArrTxt(j)
.Execute
End With
Do While .Find.Found
If .InRange(Rng) Then
.Text = LCase(ArrTxt(j))
.Find.Execute
Else
Exit Do
End If
Loop
.Start = RngTxt.Start
.Collapse wdCollapseStart
Next j
End With
While InStr(.Text, ":") > 0
.MoveStartUntil ":", wdForward
.Start = .Start + 1
.MoveStartWhile " ", wdForward
.Words.First.Case = wdTitleWord
Wend
End With
Next i
End With
End Sub