Sub TrueTitleCase()
Dim rSel As Range, oRng As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long

    Set oRng = Selection.Range
    Set rSel = Selection.Range
    'count the characters in the selected string
    k = Len(rSel)
    If k < 1 Then
        'If none, then no string is selected
        'so warn the user
        MsgBox "Select the text first!", vbOKOnly, "No text selected"
        Exit Sub    'and quit the macro
    End If
    'format the selected string as title case
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
                      "If", "In", "Of", "On", "Or", "The", "To", "With")
    'list their replacements in a matching array
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
                      "if", "in", "of", "on", "or", "the", "to", "with")
    With rSel
        .Case = wdTitleWord
        'list the exceptions to look for in an array
        With .Find
            'replace items in the first list
            'with the corresponding items from the second
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Format = True
            .MatchCase = True
            For i = LBound(vFindText) To UBound(vFindText)
                .Text = vFindText(i)
                .Replacement.Text = vReplText(i)
                .Execute Replace:=wdReplaceAll
            Next i
        End With
    End With
    FixColon oRng
lbl_Exit:
    Set rSel = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Private Sub FixColon(oRng As Range)
Const sList As String = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim rSel As Range
    oRng.Select
    Set rSel = Selection.Range
    With rSel.Find
        .Text = ":"
        Do While .Execute
            If rSel.InRange(oRng) = False Then Exit Do
            rSel.MoveStartUntil sList
            rSel.Characters(1).Case = wdUpperCase
            rSel.Collapse 0
        Loop
    End With
    oRng.Select
lbl_Exit:
    Exit Sub
End Sub