Sub FormatTables()
Application.ScreenUpdating = False
Dim oTbl As Table, oCel As Cell, Rng As Range, i As Long, bDel As Boolean
With ActiveDocument
  For Each oTbl In .Tables
    With oTbl
      Set Rng = .Cell(1, 1).Range
      Rng.End = Rng.End - 1
      If UCase(Rng.Text) <> "DATE" And UCase(Rng.Text) <> "PERIOD" Then GoTo NextTable
      For i = .Rows.Count To 1 Step -1
        With .Rows(i)
          If .Cells.Count > 1 Then
            Set Rng = .Range
            bDel = False
            If bDel = False Then bDel = FindText(Rng, "<[Aa][Gg][Ee]>")
            If bDel = False Then bDel = FindText(Rng, "%")
            If bDel = False Then bDel = FindText(Rng, "<[0-9]{1,2} [JFMASOND][anebrpyulgctov]{2} [0-9]{2}>")
            If bDel = False Then bDel = Not FindText(Rng, "[A-Za-z0-9\>]")
            If bDel = False Then
              Set Rng = oTbl.Rows(i).Range
              Rng.Start = Rng.Cells(2).Range.Start
              If Len(Rng.Text) > (Rng.Cells.Count + 1) * 2 Then
                bDel = Not FindText(Rng, "[A-Za-z1-9\>]")
              End If
            End If
          End If
          If bDel = True Then .Delete
        End With
      Next
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Text = "([0-9,.]{1,})"
        .Replacement.Text = "$\1"
        .Execute Replace:=wdReplaceAll
        .Text = "[$]{2,}"
        .Replacement.Text = "$"
        .Execute Replace:=wdReplaceAll
        .Text = "\>[ ]@"
        .Replacement.Text = ">"
        .Execute Replace:=wdReplaceAll
        .Text = "[ ]@\>"
        .Replacement.Text = ">"
        .Execute Replace:=wdReplaceAll
        .Text = "\>"
        .Replacement.Text = "     "
        .Execute Replace:=wdReplaceAll
      End With
      .Range.Font.Size = 9
      .TopPadding = 5
      .BottomPadding = 2
    End With
NextTable:
  Next
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
 
Function FindText(Rng As Range, StrFnd As String) As Boolean
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = True
  .Text = StrFnd
  .Replacement.Text = ""
  .Execute
End With
FindText = Rng.Find.Found
End Function