Speed-up merge empty 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 | |
---------------------
| | B | C | D | |
---------------------
| | B | C | D | |
---------------------
|A2| B2| C2| D2| |
---------------------
| | B2| C2| D2| |
---------------------

will be converted to

-------------------------
|A | BBB | CCC | DDD |
|A2| B2B2| C2C2| D2D2|
-------------------------

The problem is that it takes a very long time for tables with more than 50 rows.

Do you have any ideas on how to speed-up this macro?

Thank you,

Catalin Florean.


'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

 

[Helmut Weber]

Hi Catalin,

without understanding what you really want to do,
in general, in tables selection seems to be faster than range.
See the posting: "Processing paragraphs with find"
by Conny Roloff from December 31st, 2004.

I can't get your macro to work anyway.
From your code, it seems, you want to merge the cells
in column 1 vertically, as long as there is an empty cell
in column 1 under a cell in column 1, that contains some text.

Like:

---------------------
|A | B | C | D | |
---------------------
| | B | C | D | |
---------------------
| | B | C | D | |
---------------------
|A2| B2| C2| D2| |
---------------------
| | B2| C2| D2| |
---------------------

should be converted to

---------------------
|A | B | C | D | |
------------------
| | B | C | D | |
------------------
| | B | C | D | |
---------------------
|A2| B2| C2| D2| |
------------------
| | B2| C2| D2| |
----------------------

in your example
Input:
---------------------
|A | B | C | D | |
---------------------
| | B | C | D | |
---------------------
| | B | C | D | |
---------------------

Output:

-------------------------
|A | BBB | CCC | DDD |
-------------------------

I can't see any merging of cells at all,
but adding contents of a cell in row x to the contents
of a cell in row x-1 in the same column
if the cell in column 1 of row x is empty and
the cell in column 1 of row x-1 is not.


Greetings from Bavaria, Germany

Helmut Weber, MVP
"red.sys" & chr(64) & "t-online.de"
Word XP, Win 98
http://word.mvps.org/

 

[Catalin Florean via OfficeKB.com]

Hi,

Thanks for you reply.

The output should be:

Input:
---------------------
|A | B | C | D | |
---------------------
| | B | C | D | |
---------------------
| | B | C | D | |
---------------------

Output:

-------------------
|A | B | C | D |
| | B | C | D |
| | B | C | D |
-------------------

"From your code, it seems, you want to merge the cells
in column 1 vertically, as long as there is an empty cell
in column 1 under a cell in column 1, that contains some text."

This is what I want.

I will take a look at the posting: "Processing paragraphs with find".


Catalin Florean
Bucharest - Romania

 

[Catalin Florean via OfficeKB.com]

Hi,

I found a way to do this much faster.

Catalin Florean.


Sub tmpTable()
' Disable screen update
Application.ScreenUpdating = False

' Work only on the first table in ActiveDocument
Set myTable = ActiveDocument.Tables(1)
' Number of columns in myTable
countCol = myTable.Columns.Count
' Number of rows in myTable
countRow = myTable.Rows.Count

' For each row in myTable
For currentRow = 1 To countRow
' If the current row in the first colum is empty
If Len(myTable.Cell(currentRow, 1).Range) = 2 Then
' For each columns in myTable
For j = 1 To countCol
' Merge the empty cell with the cell on the row above
myTable.Cell(currentRow, 0).Merge MergeTo:=myTable.Cell(currentRow - 1, j)
Next j
' Reset the number of rows in myTable (changed by merging)
countRow = myTable.Rows.Count
' Reset the current row position
currentRow = currentRow - 1
End If
Next currentRow

'Enable screen update
Application.ScreenUpdating = True

End Sub