Sub TrueTitleCase()  ' Graham Mayor
'   Graham Mayor vba examples page 2
'   Creates true title case - sort of
'   See http://www.gmayor.com/word_vba_examples_2.htm
'   2014-01-31 - tab formatting added to vba by ckk
'
    Dim sText As range, vFindText As Variant, vReplText As Variant, _
        i As Long, k As Long, m As Long
        '
    Set sText = Selection.range
    'count the characters in the selected string
    k = Len(sText)
    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
    sText.Case = wdTitleWord
    'list the exceptions to look for in an array
    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 sText
        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
        'Reduce the range of the selected text
        'to encompass only the first character
        .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
        'format that character as upper case
        .Case = wdUpperCase
        'restore the selected text to its original length
        .MoveEnd Unit:=wdCharacter, Count:=k
        'and check to see if the string contains a colon
        If InStr(1, sText, ":") > 0 Then
            'If it does note the position of the character
            'after the first colon
            m = InStr(1, sText, ":") + 1
            'and set that as the new start of the selected text
            .MoveStart wdCharacter, m
            'set the end of the selected text to include
            'one extra character
            .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
            'format that character as upper case
            .Case = wdUpperCase
        End If
    End With
  End Sub