ActiveDocument.Content.Find

Sub TableCleaner()
Application.ScreenUpdating = False
Dim Tbl As Table, Cel As Cell, Rng As Range, Para As Paragraph
With ActiveDocument
  For Each Tbl In .Tables
    With Tbl.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = True
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = "[^t]"
      .Replacement.Text = " "
      .Execute Replace:=wdReplaceAll
      .Text = "[ ]{2,}"
      .Replacement.Text = " "
      .Execute Replace:=wdReplaceAll
      .Text = "[^l^13]{1,}"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13 ]{2,}"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
    End With
    For Each Cel In Tbl.Range.Cells
      Set Rng = Cel.Range
      Rng.End = Rng.End - 1
      If Rng.Start <> Rng.End Then
        For Each Para In Rng.Paragraphs
          With Para.Range
            If .Characters.Count = 1 And .Cells.Count = 1 Then
              .Characters.First = vbNullString
              On Error Resume Next
              If .End = .Cells(1).Range.End Then .Characters.Last.Previous.Delete
            End If
            If .End = Rng.End Then Rng.Characters.Last = vbNullString
          End With
        Next
      End If
    Next
  Next
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub