Sub Apply_True_Title_Case_by_Style()
Application.ScreenUpdating = False
Dim StyleName As String, wrd As Long, Count As Long
Const lclist As String = " a an and as at but by for from if in is of " _
  & " on or the this to "
StyleName = "Heading 1"
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Wrap = wdFindStop
      .Forward = True
      .Format = True
      .MatchWildcards = False
      .Text = ""
      .Style = ActiveDocument.Styles(StyleName)
      .Execute
    End With
    Do While .Find.Found = True
      Count = Count + 1
      With .Duplicate
        .Case = wdTitleWord
        For wrd = 2 To .ComputeStatistics(wdStatisticWords)
          If InStr(lclist, " " & LCase(Trim(.Words(wrd))) & " ") > 0 Then _
            .Words(wrd).Case = wdLowerCase
        Next wrd
      End With
      .Collapse wdCollapseEnd
      If (ActiveDocument.Range.End - .End) < 2 Then Exit Do
      .Find.Execute
    Loop
  End With
End With
Select Case Count
Case 0
  MsgBox "Macro could not find any instances of '" & StyleName & "'.", vbOKOnly, "Results"
Case 1
  MsgBox "Macro applied true title case to 1 instance of '" & StyleName & "'.", vbOKOnly, "Results"
Case Is > 1
  MsgBox "Macro applied true title case to " & Count & " instances of '" & StyleName & "'.", vbOKOnly, "Results"
End Select
Application.ScreenUpdating = True
End Sub