Speed-up merge emply cells in msword tables

[Catalin Florean via OfficeKB.com]

Hello,

I have a small VBA code that merge empty cell on each rows but keeping the columns.
For example the table:

A B C D
BB



'My macro:

Sub tmpTable()
Application.ScreenUpdating = False

cateMerge = 0
Set myTable = ActiveDocument.Tables(1)
cateCol = myTable.Columns.Count
cateRow = myTable.Rows.Count

For currentRow = 1 To cateRow
If Len(myTable.Cell(currentRow, 1).Range.Text) <= 2 Then
cateMerge = cateMerge + 1
For j = 1 To cateCol - 1
myTable.Cell(currentRow, 0).Merge MergeTo:=myTable.Cell(currentRow - cateMerge, j)
Next j
Else
cateMerge = 0
End If
Next currentRow
myTable.Columns(cateCol).Delete

Application.ScreenUpdating = True

End Sub