Try this:

Sub RevisedTitleCase()
Dim oRng As Range
Dim arrFind() As String
Dim i As Long
Set oRng = Selection.Range
If oRng.Words.Count < 1 Then
MsgBox "Nothing selected to process. Please select text to process and try again.", vbInformation + vbOKOnly, "Nothing Selected"
Exit Sub
End If
'Apply title case
oRng.Case = wdTitleWord
'list the exceptions to look for in an array
arrFind = Split("A|An|And|As|At|But|By|For|If|In|Of|On|Or|Th e|To|With", "|")
With oRng
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Format = True
.MatchCase = True
For i = LBound(arrFind) To UBound(arrFind)
.Text = arrFind(i)
.Replacement.Text = LCase(arrFind(i))
.Execute Replace:=wdReplaceAll
Next i
End With
With .Find
.Text = ": [A-Za-z]"
.MatchWildcards = True
While .Execute
oRng.Case = wdUpperCase
oRng.Collapse wdCollapseEnd
Wend
End With
Selection.Characters(1).Case = wdTitleSentence
End With
End Sub

__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/