Public Sub FormatAllTables()
Application.ScreenUpdating = False
'Sets first row of each table as a repeating header and its style to "Title"
Dim Tbl As Word.Table
For Each Tbl In ActiveDocument.Tables
  With Tbl.Rows(1)
    .HeadingFormat = True
    .Range.Style = "title"
    .Range.Case = wdTitleWord
    Call TrueTitleCase(.Range)
  End With
  Tbl.Rows(2).Range.ParagraphFormat.SpaceBefore = 3
Next Tbl
Application.ScreenUpdating = True
End Sub
 
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")
Set RngTxt = Rng
With RngTxt
  For i = 1 To .Sentences.Count
    With .Sentences(i)
      If Len(.Text) > 2 And .Characters.Last = .Cells(1).Range.Characters.Last Then .End = .End - 1
      .MoveStart wdWord, 1
      If Len(.Text) > 0 Then
        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
            .MatchCase = True
            .Text = ArrTxt(j)
            .Replacement.Text = ""
            .Execute
          End With
          Do While .Find.Found = True
            If .InRange(Rng) Then
              .Text = LCase(.Text)
              .Collapse wdCollapseEnd
              .Find.Execute
            Else
              Exit Do
            End If
          Loop
        Next j
        While InStr(.Text, ":") > 0
          .MoveStartUntil ":", wdForward
          .Start = .Start + 1
          .MoveStartWhile " ", wdForward
          .Words.First.Case = wdTitleWord
        Wend
      End If
    End With
  Next i
End With
End Sub