Delete Blank Rows Bombs on Merged Tables :-(

[AaronT]

Hello All! A few months ago, I got this really great code that loops through all tables in a doc and deletes blank rows. I just realized it bombs when it encounters a table with merged cells in it. This is not good. I've been trying to tweak it to go to next row or cell if it comes across a table with merged cells; no luck. The best I've been able to do is get it to go to the next table. This is not very helpful as I now have a doc full of tables with empty rows...lol...will someone please help me?

Here is the code. Thank you in advance!


Dim tblT As Table
Dim cllC As Cell
Dim blnEmpty As Boolean
Dim n As Integer
Dim t As String
On Error GoTo ErrHnd

'loop through all tables in the document
For Each tblT In ActiveDocument.Tables()
'loop through each row in table, starting at the end
'of the table - so delete doesn't change row numbers
For n = tblT.Rows.Count To 2 Step -1
'set flag for empty row
blnEmpty = True
'go through each cell in row

For Each cllC In tblT.Rows(n).Cells()
'test if cell contains more than table marker
If cllC.Range.Characters.Count > 1 Then
'if any cell has more than table marker
'the cell and therefore the row is not empty
blnEmpty = False
End If
Next cllC
'if all cells in row empty - delete row
If blnEmpty = True Then
tblT.Rows(n).Delete
tblT.PreferredWidthType = wdPreferredWidthPercent
tblT.PreferredWidth = 99
End If

Next n
nexttable:
Next tblT

'MsgBox "All Done!"
Exit Sub
Error handler
ErrHnd:
'MsgBox "Error: " & Err.Description
Err.Clear
Resume nexttable:


End Sub

[AaronT]

I would like to preserve at least one blank row in the table if possible. I would really appreciate some VBAX help! :-)

Thanks again!

Aaron

[macropod]

Hi Aaron,

There is no direct way of handling merged or split cells in vba, due to the lack of a 'merged' or 'split' property that can be tested.

You might get better results by copying the affected tables to a temporary Excel worksheet and using Excel's tools to do the processing. Here's an Excel macro that would do the job (once you have the data in there):
Sub DeleteBlankRows()
Dim Rng As Range, i As Integer, j As Integer, Str As String
Set Rng = ActiveSheet.UsedRange
For i = Rng.Rows.Count To 1 Step -1
Str = ""
For j = 1 To Rng.Columns.Count
Str = Str & Trim(Rng.Cells(i, j))
Next j
If Trim(Str) = "" Then Rng.Cells(i, 1).EntireRow.Delete
Next i
End Sub
I'll leave it to you to do the Excel automation & table copying/pasting both ways, if that's the route you want to go down.

[AaronT]

Thank you, madropod! I'm not sure this will be a practical solution, but it sounds like there is really no other way around this. I really appreciate your assistance!

[Benzadeus]

I tested your code with merged cells on a table and it worked... your code deleted rows on a table even if cells were merged.

Care to upload a Document you are having errors?

[macropod]

Hi Felipe,

Perhaps you should try with a mix of verically and horizontally merged cells ...

[Benzadeus]

You are right, macropod. I got error when I tried running with vertically merged cells.

I adopted your suggestion (handling Word's table with Excel):
'SAVE YOUR WORK BEFORE EXECUTING CODE BELOW
'You'll lose all Word's table formating!

'You must set references to Excel in order to execute this code
'Tools -> References -> Microsoft Excel XX.0
Sub Delete_Empty_Rows_Words_Tables()

Dim doc As Document

Dim appExcel As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim rng As Excel.Range

Dim i As Long, j As Long
Dim str As String
Dim t As Long
Dim blExcelWasClosed As Boolean

Set doc = ActiveDocument

On Error Resume Next
Set appExcel = GetObject(, "Excel.Application")
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
blExcelWasClosed = True
Else
End If
On Error GoTo 0
appExcel.Visible = True

Set wb = appExcel.Workbooks.Add

'Couldn't perform a For Each Table here because it gets on infinite loop,
'so counting tables was implemented.
For t = doc.Tables.Count To 1 Step -1
doc.Tables(t).Select
doc.ActiveWindow.Selection.Copy
Set ws = wb.Sheets.Add
ws.Paste

'I know I shouldn't use UsedRange on 'With's...
With ws.UsedRange
For i = .Rows.Count To 1 Step -1
str = ""
For j = 1 To .Columns.Count
str = str & Trim(.Cells(i, j))
Next j
If Trim(str) = "" Then .Rows(i).EntireRow.Delete
Next i

.Copy
doc.Tables(t).Delete
'If the new table has no rows, you'll get an error. Handle that if you want
doc.ActiveWindow.Selection.Paste
End With
Next t

wb.Close SaveChanges:=False
If blExcelWasClosed Then appExcel.Quit

Set appExcel = Nothing

End Sub

The bad think of this code, as mentioned on code's comment, is that the user will lose all formating.

[Benzadeus]

By the way, you can change
For i = .Rows.Count To 1 Step -1
str = ""
For j = 1 To .Columns.Count
str = str & Trim(.Cells(i, j))
Next j
If Trim(str) = "" Then .Rows(i).EntireRow.Delete
Next i
for
For i = .Rows.Count To 1 Step -1
If appExcel.WorksheetFunction.CountA(.Rows(i)) = 0 Then .Rows(i).EntireRow.Delete
Next i

I didn't do this before because I was getting a strange behavior when calling WorksheetFunction.CountA from Word VBA (returned only 16384), but I don't know why it now works properly.