Sub TrueTitleCase(Rng As Range)
Dim RngTxt As Range, ArrTxt(), i As Long, j As Long
'list the exceptions to look for in an array
ArrTxt = Array("A", "An", "And", "As", "At", "But", "By", _
  "For", "If", "In", "Of", "On", "Or", "The", "To", "With")
With Rng
  For i = 1 To .Sentences.Count
    Set RngTxt = .Sentences(i)
    With RngTxt
      .End = .End - 1
      If .Information(wdWithInTable) And .Start = .End Then
        .MoveStart wdCell, -1
        .End = .End - 1
      End If
      .MoveStart wdWord
      With .Duplicate
        For j = LBound(ArrTxt) To UBound(ArrTxt)
          With .Find
            'replace items in the list
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Format = False
            .Replacement.Text = ""
            .Text = ArrTxt(j)
            .Execute
          End With
          Do While .Find.Found
            If .InRange(Rng) Then
              .Text = LCase(ArrTxt(j))
              .Find.Execute
            Else
              Exit Do
            End If
          Loop
          .Start = RngTxt.Start
          .Collapse wdCollapseStart
        Next j
      End With
      While InStr(.Text, ":") > 0
        .MoveStartUntil ":", wdForward
        .Start = .Start + 1
        .MoveStartWhile " ", wdForward
        .Words.First.Case = wdTitleWord
      Wend
    End With
  Next i
End With
End Sub