What I think you require here is to convert a title that is at the start of a document from upper case to true title case e.g.
Code:
Option Explicit
Sub FormatTitle()
Const sList As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 -"
Dim rngTitle As Range
Set rngTitle = ActiveDocument.Range
rngTitle.Collapse 1
rngTitle.MoveEndWhile sList
TrueTitleCase rngTitle
End Sub
Sub TrueTitleCase(oRng As Range)
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long
Dim m As Long
'count the characters in the selected string
k = Len(oRng)
If k < 1 Then
'If none, then the range is empty
'so warn the user
MsgBox "The range has no text!", vbOKOnly, "No text selected"
Exit Sub 'and quit the macro
End If
'format the selected string as title case
oRng.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 oRng
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(oRng) + 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, oRng, ":") > 0 Then
'If it does note the position of the character
'after the first colon
m = InStr(1, oRng, ":") + 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(oRng) + 1
'format that character as upper case
.Case = wdUpperCase
End If
End With
lbl_Exit:
Exit Sub
End Sub