True title case

Word has the ability to set a block of text in title case, i.e. each of the words formatted so that its first letter is capitalized, thus: A Tale Of Two Cities but formatting styles often dictate that articles, prepositions, and conjunctions should be in lower case, thus: A Tale of Two Cities. Word has no built-in function to perform this type of formatting, but it can be achieved with a macro. The following sets the selected text in Word's title case and then sets all the words in the first array: vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _ "If", "In", "Of", "On", "Or", "The", "To", "With") to their lower case equivalents with a corresponding array vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _ "if", "in", "of", "on", "or", "the", "to", "with") The list of corrections can be expanded as required by simply adding the word in its alternative forms to both lists. If one of the listed words was the first word in the selected text, then it too would be set in lower case, so that too needs to be corrected, and similarly if there is a colon in the selected text, the word following the colon would need to be corrected. The macro forces capitalization on the first letters of all words that appear in either position.

Sub TrueTitleCase() Dim sText As Range Dim vFindText As Variant Dim vReplText As Variant Dim i As Long Dim k As Long Dim 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