Sub Apply_True_Title_Case_by_Style()
Dim oRng As Range
Dim oPara As Paragraph
Dim StyleName As String
Dim vFindText As Variant
Dim vReplText As Variant
Dim wrd As Integer

    StyleName = "Heading 1"
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
                      "If", "In", "Of", "On", "Or", "The", "To", "With")
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
                      "if", "in", "of", "on", "or", "the", "to", "with")

    For Each oPara In ActiveDocument.Paragraphs
        If oPara.Style = StyleName Then
            Set oRng = oPara.Range
            oRng.Case = wdTitleWord
            With oRng.Find
                For wrd = LBound(vFindText) To UBound(vFindText)
                    .Text = vFindText(wrd)
                    .Replacement.Text = vReplText(wrd)
                    .Execute MatchCase:=True, Replace:=wdReplaceAll
                Next wrd
            End With
        End If
    Next oPara
End Sub

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

Sub Greg_Apply_True_Title_Case_by_Style()
Dim oPar As Paragraph
Dim oRng As Range
Dim arrFind() As String
Dim lngIndex As Long
  arrFind = Split("A,An,And,As,At,But,By,For,If,In,Of,On,Or,The,To,With", ",")
  For Each oPar In ActiveDocument.Paragraphs
    If oPar.Style = "Heading 1" Then
      Set oRng = oPar.Range
      oRng.Case = wdTitleWord
      With oRng.Find
        For lngIndex = 0 To UBound(arrFind)
          .Text = arrFind(lngIndex)
          .Replacement.Text = LCase(.Text)
          .MatchWholeWord = True
          .Execute MatchCase:=True, Replace:=wdReplaceAll
        Next lngIndex
      End With
    End If
  Next oPar
End Sub

Option Explicit
Sub Apply_True_Title_Case_by_Style()
Const strLCList As String = " a an and as at but by for from if in is of on or the this to "
Dim strStyleName As String
Dim oRng As Range
Dim lngIndex As Long, lngStyleCount As Long
  strStyleName = "Heading 1"
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Wrap = wdFindStop
    .Forward = True
    .Format = True
    .MatchWildcards = False
    .Text = ""
    .Style = ActiveDocument.Styles(strStyleName)
    Do While .Execute
      lngStyleCount = lngStyleCount + 1
      If oRng.End = ActiveDocument.Range.End Then Exit Do
      oRng.Collapse wdCollapseEnd
    Loop
  End With
  Select Case lngStyleCount
    Case 0:
      MsgBox "There are no occurrences of  "" & strStyleName & "" style in this document.", _
              vbInformation + vbOKOnly, "Style Count"
      Exit Sub
    Case 1
      If MsgBox("There is 1 occurrence of  " & Chr(34) + strStyleName + Chr(34) & " style in this document." & vbCr & vbCr _
              & "Do you want to apply true title case to it?", vbQuestion + vbYesNo, "Style Count") = vbNo Then
       Exit Sub
      End If
    Case Else
      If MsgBox("There are " & lngStyleCount & " occurrences of  " & Chr(34) + strStyleName + Chr(34) & _
                " style in this document." & vbCr & vbCr _
              & "Do you want to apply true title case to them?", vbQuestion + vbYesNo, "Style Count") = vbNo Then
        Exit Sub
      End If
  End Select
  Application.ScreenUpdating = False
  Set oRng = ActiveDocument.Range
  With oRng
    With .Find
      .ClearFormatting
      .Wrap = wdFindStop
      .Forward = True
      .Format = True
      .MatchWildcards = False
      .Text = ""
      .Style = ActiveDocument.Styles(strStyleName)
    End With
    Do While .Find.Execute
      With .Duplicate
        .Case = wdTitleWord
        For lngIndex = 2 To .ComputeStatistics(wdStatisticWords)
          If InStr(strLCList, " " & LCase(Trim(.Words(lngIndex))) & " ") > 0 Then
            .Words(lngIndex).Case = wdLowerCase
          End If
        Next lngIndex
      End With
      If .End = ActiveDocument.Range.End Then Exit Do
      .Collapse Direction:=wdCollapseEnd
    Loop
  End With
  Application.ScreenUpdating = True
  Select Case lngStyleCount
    Case 1
      MsgBox "Macro applied true title case to 1 instance of " & Chr(34) & strStyleName & Chr(34) & ".", vbOKOnly, "Results"
    Case Is > 1
      MsgBox "Macro applied true title case to " & lngStyleCount & " instances of " & Chr(34) & strStyleName & Chr(34) & ".", vbOKOnly, "Results"
  End Select
lbl_Exit:
  Exit Sub
End Sub