Repost: Detected merged cells.

[Vince]

Jezebel,

I am sorry to repost but I fear you (or others) may think that my question is
solved. I would be grateful for answers to this.

Vince

---------------------------------------

Thanks for your reply.

I am totally stuck here (coffee or loo break didn't help either). Here's my
code:


For i = 1 To ActiveDocument.Tables.Count

ActiveDocument.Tables(i).Select

If Not ActiveDocument.Tables(i).Uniform Then
For j = 1 To ActiveDocument.Tables(i).Rows.Count

For Each acell In ActiveDocument.Tables(i).Rows(j).Cells
acell.Select

MsgBox acell.Range.text & " " & acell.ColumnIndex & " " & "
" & acell.Next.ColumnIndex

Next
Next

End If

Next

The column index value seems to be the real value (as it appears in the
table) and the merged cells are ignored. What I mean is, supposing the row
has 7 cells:
CELLS: 1,1 1,2 - 1,3 1,4 - 1,5 1,5 - 1,6
COLUMNS: 1 2-3 4-5 5-6


I don't get "1 2 ; 2 4 ; 4 6; 6 1 " as my message box returns, I instead
get: "1 2; 2 3 ; 3 4 ; 4 1" meaning word pretends that the cells that were
merged aren't there. How can I detect the span then? Please help me figure
this out!

Thanks a lot!

Vince

 

[Helmut Weber]

Hi Vince,

I think there is no straightforward way to do this,
as Word understandably does not record all of the
history of a document. Cells could have been merged
and split again over and over. The real question would
be if a cell is the result of two or more cells. No way,
but you might compare two rows and check, whether
there is a cell in one row which as a left border position
of a cell in the other row and a right border position
of another cell in the other row. Which doesn't proof
that such a cell is the result of merging, but it is likely.

Sample to get the border position of cells in two
adjacent rows:

Sub Makro1()
Dim sLeft As Single ' left border position
Dim sRite As Single ' right border position
Dim oRw1 As Row ' Row 1
Dim oRw2 As Row ' row 2
Dim oCll As Cell
Dim WidthRow1(4, 1) As Single ' Array of cell border position
Dim WidthRow2(4, 1) As Single
Dim oTbl As Table
Dim r As Long ' rows
Dim c As Long ' cells

Set oTbl = ActiveDocument.Tables(1)
sLeft = 0
For r = 1 To oTbl.Rows.Count - 1
c = 0
Set oRw1 = oTbl.Rows(r)
Set oRw2 = oTbl.Rows(r + 1)
For Each oCll In oRw1.Cells
c = c + 1
sRite = sLeft + oCll.Width
WidthRow1(c, 0) = sLeft
WidthRow1(c, 1) = sRite
sLeft = sRite
Debug.Print c, _
Format(WidthRow1(c, 0), "0000.0"), _
Format(WidthRow1(c, 1), "0000.0")
Next
c = 0
sLeft = 0
For Each oCll In oRw2.Cells
c = c + 1
sRite = sLeft + oCll.Width
WidthRow2(c, 0) = sLeft
WidthRow2(c, 1) = sRite
sLeft = sRite
Debug.Print c, _
Format(WidthRow2(c, 0), "0000.0"), _
Format(WidthRow2(c, 1), "0000.0")
Next
Next
End Sub

Then there comes the so far unfinished tricky part,
to compare the two arrays and to find out,
if there is a cell in a row which has a left border position
of a cell in the other row and a right border position of
another cell in the other row. Doable. But I wonder,
whether it's worth the effort, under the aspect, that
cell borders may have been changed manually and
nothing systematic is left.

Greetings from Bavaria

Helmut Weber, MVP
"red.sys" & chr$(64) & "t-online.de"
Win XP, Office 2003

 

[Vince]

Thanks Helmut.

I understand your idea. Kind of like my other idea where I check the row
with the maximum number of columns and then get the least column width from
a cell there (hoping it is the typical cell). Then I iterate through the
table and dividing each cell by that column width and then split if the
value is greater than one. After splitting, I do a "tab" on the new cells
and then feed the whole table to a perl program that I wrote which tags the
table counting the tabs and blah blah (pretty unusual program). Then, I get
back the tags in VBA and replace them with the selection (which will hold
the table).

After all this, I wonder what the dudes who are testing are going to say! I
am 50% through with developing all this.

Here's the code I used.

Sub PreProcessTables()
Dim i As Integer
Dim j, k As Integer
Dim aCell As Cell
Dim bCell As Cell
Dim RowNumber As Integer

Dim MaximumCols As Integer
Dim MinColumnWidth As Double
Dim Counter, Counter2 As Integer
Dim Suse As String

For i = 1 To ActiveDocument.Tables.Count
Call DoCaptions("Processing table: " & i & " of " &
ActiveDocument.Tables.Count)
ActiveDocument.Tables(i).Select

If Not ActiveDocument.Tables(i).Uniform Then

Call DoCaptions("Calculating Maximum columns")

MaximumCols = ReturnMaxTableColumns(i, RowNumber)
MinColumnWidth = ReturnMinColumnWidth(i, RowNumber)

For j = 1 To ActiveDocument.Tables(i).Rows.Count
Call DoCaptions("Reading row : " & j & " of " &
ActiveDocument.Tables(i).Rows.Count & " in table " & i)

For Each aCell In ActiveDocument.Tables(i).Rows(j).Cells
aCell.Select

Counter = Int(aCell.Width / MinColumnWidth)
If Counter > 1 Then
'MsgBox "spanning: " & Counter & " rows"
Call DoCaptions("Killing span")
aCell.Split numcolumns:=Counter

'MsgBox aCell.Range.text
Suse = aCell.Range.text
Counter2 = Counter

While Counter2 > 1
Set bCell = aCell.Next
Counter2 = Counter2 - 1
bCell.Select
Suse = Suse & bCell.Range.text
'MsgBox bCell.Range.text
bCell.Range.text = vbTab
Wend
Suse = Replace(Suse, vbTab, "")
Suse = Replace(Suse, Chr(7), "")
Suse = Replace(Suse, Chr(10), "")
Suse = Replace(Suse, Chr(13), "")

aCell.Range.text = Suse

End If

Next
Next

End If

Next






End Sub

Function ReturnMinColumnWidth(TableNumber As Integer, RowNumber As Integer)
As Double
Dim aCell As Cell
Dim MW As Double
MW = 8000000

For Each aCell In ActiveDocument.Tables(TableNumber).Rows(RowNumber).Cells
If aCell.Width < MW Then MW = aCell.Width
Next

ReturnMinColumnWidth = MW


End Function

Function ReturnMaxTableColumns(TableNumber As Integer, ByRef RowNumber As
Integer) As Integer
Dim aCell As Cell
Dim R As Row
Dim max As Integer

For Each R In ActiveDocument.Tables(TableNumber).Rows
For Each aCell In R.Cells
If aCell.ColumnIndex > max Then
max = aCell.ColumnIndex
RowNumber = aCell.RowIndex
End If
Next
Next
ReturnMaxTableColumns = max
End Function