Sub DeleteEmptyTablerowsandcolumns()
Application.ScreenUpdating = False
    Dim Tbl As Table, cel As Cell, i As Long, n As Long, fEmpty As Boolean
    
    With ActiveDocument
        For Each Tbl In .Tables
        n = Tbl.Columns.Count
            For i = n To 1 Step -1
                fEmpty = False
                For Each cel In Tbl.Columns(i).Cells
                    If Len(cel.Range.Text) <= 2 Or IsNull(cel.Range.Text) Or IsEmpty(cel.Range.Text) Or cel.Range.Text = "" Then
                        fEmpty = True
                    End If
                    Next cel
                    If fEmpty = True Then Tbl.Columns(i).Delete
                Next i
        Next Tbl
    End With
End Sub