Sub DeleteEmptyTableRowsAndColumns()
Application.ScreenUpdating = False
Dim Tbl As Table, i As Long
For Each Tbl In ActiveDocument.Tables
  With Tbl
    For i = .Rows.Count To 1 Step -1
      With .Rows(i)
        If Len(.Range) = .Cells.Count * 2 + 2 Then .Delete
      End With
    Next i
    With .Range
      For i = .Cells.Count To 1 Step -1
        On Error Resume Next
        If Len(.Cells(i).Range) = 2 Then
          .Columns(.Cells(i).ColumnIndex).Delete
        End If
      Next i
    End With
  End With
Next Tbl
Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub