Sub FormatTables()
Application.ScreenUpdating = False
Dim oTbl As Table, oCel As Cell, Rng As Range, i As Long
With ActiveDocument
  For Each oTbl In .Tables
    On Error Resume Next
    With oTbl
      For i = .Rows.Count To 1 Step -1
        With .Rows(i)
          If .Cells.Count > 1 Then
            Set Rng = .Range
            If FindText(Rng, "/%") = True Then .Delete
            If FindText(Rng, "<[0-9]{1,2} [JFMASOND][anebrpyulgctov]{2} [0-9]{2}>") = True Then .Delete
            If FindText(Rng, "<[Aa][Gg][Ee]>") = True Then .Delete
            If FindText(Rng, "[A-Za-z0-9]") = False Then .Delete
            Rng.Start = .Cells(2).Range.Start
            If FindText(Rng, "[!0]") = False Then .Delete
          End If
        End With
      Next
      For Each oCel In .Range.Cells
        Set Rng = oCel.Range
        With Rng
          .End = .End - 1
          If IsNumeric(.Text) Then .Text = Format(.Text, "$#,##0")
        End With
      Next
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .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
  Next
End With
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