Hi Ilene,

no way,

unless you set up a list of prepositions.

Scrap that and go with something like:
Sub TitleCaseWithLowerCase()

Application.ScreenUpdating = False

'Capitalize all words in selection
Selection.FormattedText.Case = wdTitleWord

'Uncapitalize the listed words
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

Call DoTitleCase("The ")
Call DoTitleCase("Of ")
Call DoTitleCase("And ")
Call DoTitleCase("Or ")
Call DoTitleCase("But ")
Call DoTitleCase("A ")
Call DoTitleCase("An ")
Call DoTitleCase("To ")
Call DoTitleCase("In ")
Call DoTitleCase("With ")
Call DoTitleCase("From ")
Call DoTitleCase("By ")
Call DoTitleCase("Out ")
Call DoTitleCase("That ")
Call DoTitleCase("This ")
Call DoTitleCase("For ")
Call DoTitleCase("Against ")
Call DoTitleCase("About ")
Call DoTitleCase("Between ")
Call DoTitleCase("Under ")
Call DoTitleCase("On ")
Call DoTitleCase("Up ")
Call DoTitleCase("Into ")

'Uncomment the next line if you want the selection dismissed.
'Selection.Collapse wdCollapseStart

're-capitalize first word in title
Selection.Characters(1).Case = wdUpperCase

End Sub
Sub DoTitleCase(FindText As String)
'This procedure is called from TitleCaseWithLowerCase above

Dim r As Range
Set r = Selection.Range

With Selection.Find
.ClearFormatting
.Text = FindText
.Replacement.Text = "^&"
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.MatchWholeWord = True

Do While .Execute
Selection.FormattedText.Case = wdLowerCase
r.Select
Loop
End With
r.Select
End Sub