Finding Tables with Vertically Merged Cells

T-Belle · #1 07-16-2020, 07:28 AM

Hello to the VBA brain trust!

Is it possible to search a large document for tables that contain vertically merged cells and split the cells to rows?

If not, is it possible to highlight all tables that contain vertically merged cells? Basically, I need a way to quickly identify those tables so that I can deal with them separately.

I know just enough VBA to get by, and something like this is well beyond my feeble abilities.

gmaxey · #2 07-16-2020, 01:37 PM

Code:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oTbl As Table
  For Each oTbl In ActiveDocument.Tables
    If Not oTbl.Uniform Then oTbl.Range.Cells(1).Shading.BackgroundPatternColor = wdColorRose
  Next oTbl
lbl_Exit:
  Exit Sub
End Sub

Guessed · #3 07-16-2020, 05:17 PM

Greg's code will identify tables with any merged cells but those may include horizontally merged cells.
This code will do what you asked but it uses the Selection object because I couldn't work out how to move a range down one cell.

Code:

Sub SplitVertMergeCells()
  Dim aTbl As Table, aCell As Cell, i As Integer, aRng As Range
  Dim iRow As Integer, iCol As Integer, iSplit As Integer
  For Each aTbl In ActiveDocument.Tables
    If Not aTbl.Uniform Then
      'Debug.Print "Table size: ", aTbl.Rows.Count, aTbl.Columns.Count
      For Each aCell In aTbl.Range.Cells
        'Debug.Print aCell.RowIndex, aCell.ColumnIndex
        If aCell.RowIndex = aTbl.Rows.Count Then Exit For
        Set aRng = aCell.Range
        aRng.Select
        Selection.MoveDown Unit:=wdLine, Count:=1
        If Selection.Information(wdWithInTable) Then
          iSplit = Selection.Cells(1).RowIndex - aRng.Cells(1).RowIndex
        Else
          iSplit = aTbl.Rows.Count - aRng.Cells(1).RowIndex + 1
        End If
        If iSplit > 1 Then aCell.Split NumRows:=iSplit
      Next aCell
    End If
  Next aTbl
End Sub

I'm hoping someone can improve on this to work without the selection object.

T-Belle · #4 07-17-2020, 05:35 AM

Thank you, both! I appreciate the help.

The first code (Greg's) worked and did exactly as I asked in that it highlighted tables with merged cells, but it, in fact, highlighted all merged cells, including horizontally merged cells. The second code (Andrew's) did not work for me. I received an error indicating the requested member of the collection does not exist.

I am attaching a sanitized example of the abomination I am working with. The document is ~100 pages and contains table after table. I believe it is output from some sort of tool, and it comes to me like this. (There are times when I receive similar documents that can be several hundred pages of nothing but this mess.) I am trying to make it presentable (Heaven, help me).

I have tried to run macros to split the main table, and they work until encountering a table like the attached that contains vertically merged cells. At that point, it errors out.

The Holy Grail for me would be to fix the vertically merged cells so that I can run my other macros. If that is not possible, if I can identify the tables with only vertically merged cells (by highlighting or some other means), I could take care of those separately (i.e., manually).

Anyway, I appreciate your willingness to help more than I can adequately express.

gmaxey · #5 07-17-2020, 09:26 AM

I looked a Andrews code and while I can see it will do something, I don't see how it will catch all cases. I could be wrong.

As for identifying non-uniformity in tables, try:

Code:

Option Explicit
Sub ProcessTables()
Dim oTbl As Table
Dim oNT As Table
  For Each oTbl In ActiveDocument.Tables
    MarkNonUniformity oTbl
    For Each oNT In oTbl.Tables
      MarkNonUniformity oNT
    Next oNT
  Next oTbl
lbl_Exit:
  Exit Sub
End Sub
Sub MarkNonUniformity(oTbl As Table)
'A basic Word macro coded by Greg Maxey
Dim oRow As Row, oCol As Column
Dim bVM As Boolean, bHM As Boolean, bBoth As Boolean
  bVM = False: bHM = False: bBoth = False
  With oTbl
    If Not .Uniform Then
      On Error Resume Next
      Set oRow = .Rows(1)
      If Err.Number = 5991 Then bVM = True
      Err.Clear
      Set oCol = oTbl.Columns(1)
      If Err.Number = 5992 Then bHM = True
      If bVM And bHM Then bBoth = True
      Select Case True
        Case bBoth: .Range.Cells(1).Shading.BackgroundPatternColor = wdColorGreen
        Case bVM: .Range.Cells(1).Shading.BackgroundPatternColor = wdColorRose
        Case bHM: .Range.Cells(1).Shading.BackgroundPatternColor = wdColorPaleBlue
      End Select
    End If
  End With
lbl_Exit:
  Exit Sub
End Sub

gmaxey · #6 07-17-2020, 09:32 AM

Andrew,

To be more precise in my (unintentional) criticism, if the merged cells span a page then the those cells aren't merge using your code. Just don't have time to try to figure out why.

gmaxey · #7 07-17-2020, 10:07 AM

T-Belle

This mod of Andrews code will come close with your attached. However, the merges cells that span a page aren't split.

Code:

Sub ProcTbls()
Dim oTbl As Table, oNT As Table
  For Each oTbl In ActiveDocument.Tables
    SplitVMCs oTbl
    For Each oNT In oTbl.Tables
      SplitVMCs oNT
    Next oNT
  Next oTbl
lbl_Exit:
  Exit Sub
End Sub

Sub SplitVMCs(oTbl As Table)
Dim oCell As Cell, oRng As Range
Dim lngRow As Long, lngSplit As Long
  If Not oTbl.Uniform Then
    For Each oCell In oTbl.Range.Cells
    If oCell.RowIndex = oTbl.Rows.Count Then Exit For
      Set oRng = oCell.Range
      oRng.Select
      Selection.MoveDown Unit:=wdLine, Count:=1
      On Error GoTo Err_Cell
      If Selection.Information(wdWithInTable) Then
        lngSplit = Selection.Cells(1).RowIndex - oRng.Cells(1).RowIndex
      Else
        lngSplit = oTbl.Rows.Count - oRng.Cells(1).RowIndex + 1
      End If
Err_RE:
      If lngSplit > 1 Then oCell.Split NumRows:=lngSplit
    Next oCell
  End If
lbl_Exit:
  Exit Sub
Err_Cell:
  lngSplit = 1
  Resume Err_RE
End Sub

gmaxey · #8 07-17-2020, 10:14 AM

Andrew\T-Belle

Changing the view to Normal and combining a couple of processes will come even closer. There is still a problem is the last row has VMCs and that could be due to the Err_Handler to get passed the earlier error presented.

Code:

Sub ProcTbls()
Dim oTbl As Table, oNT As Table
Dim lngView As Long
  lngView = ActiveDocument.ActiveWindow.View
  ActiveDocument.ActiveWindow.View = wdNormalView
  Application.ScreenUpdating = False
  For Each oTbl In ActiveDocument.Tables
    SplitVMCs oTbl
    MarkNonUniformity oTbl
    For Each oNT In oTbl.Tables
      SplitVMCs oNT
      MarkNonUniformity oNT
    Next oNT
  Next oTbl
  ActiveDocument.ActiveWindow.View = lngView
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub

Sub SplitVMCs(oTbl As Table)
Dim oCell As Cell, oRng As Range
Dim lngRow As Long, lngSplit As Long
  If Not oTbl.Uniform Then
    For Each oCell In oTbl.Range.Cells
    If oCell.RowIndex = oTbl.Rows.Count Then Exit For
      Set oRng = oCell.Range
      oRng.Select
      Selection.MoveDown Unit:=wdLine, Count:=1
      On Error GoTo Err_Cell
      If Selection.Information(wdWithInTable) Then
        lngSplit = Selection.Cells(1).RowIndex - oRng.Cells(1).RowIndex
      Else
        lngSplit = oTbl.Rows.Count - oRng.Cells(1).RowIndex + 1
      End If
Err_RE:
      If lngSplit > 1 Then oCell.Split NumRows:=lngSplit
    Next oCell
  End If
lbl_Exit:
  Exit Sub
Err_Cell:
  lngSplit = 1
  Resume Err_RE
End Sub
Sub MarkNonUniformity(oTbl As Table)
'A basic Word macro coded by Greg Maxey
Dim oRow As Row, oCol As Column
Dim bVM As Boolean, bHM As Boolean, bBoth As Boolean
  bVM = False: bHM = False: bBoth = False
  With oTbl
    If Not .Uniform Then
      On Error Resume Next
      Set oRow = .Rows(1)
      If Err.Number = 5991 Then bVM = True
      Err.Clear
      Set oCol = oTbl.Columns(1)
      If Err.Number = 5992 Then bHM = True
      If bVM And bHM Then bBoth = True
      Select Case True
        Case bBoth: .Range.Cells(1).Shading.BackgroundPatternColor = wdColorGreen
        Case bVM: .Range.Cells(1).Shading.BackgroundPatternColor = wdColorRose
        Case bHM: .Range.Cells(1).Shading.BackgroundPatternColor = wdColorPaleBlue
      End Select
    End If
  End With
lbl_Exit:
  Exit Sub
End Sub

T-Belle · #9 07-17-2020, 11:28 AM

Hey there, Greg.

Thank you for troubleshooting this and for the updated code and suggestions. I will give the code a whirl this afternoon and let you know how it goes.

T-Belle · #10 07-17-2020, 04:56 PM

Hey, Greg.

OMG! Success! Thank you!!

Although it does not split the cells that span the next page, I can most definitely work with this. This will reduce the number of rogue tables, and I can more easily deal with those that remain.

I am curious why it does not split those particular cells. Do you know if this is common (i.e., just the way it is), or perhaps, is it some oddity in my document given it is output from another application?

Thank you! Thank you! This is awesome. You guys rock!

Guessed · #11 07-19-2020, 07:09 PM

Nice work Greg. I was hoping you could find a way of avoiding Selection though

The code I posted failed because of three factors I see in your posted example:
1. Nested tables were ignored
1a. Nested tables 'selection below' is still inside a table
2. Inconsistent row lengths
3. Spans across page breaks

Greg's code has solved most of these but the 1a issue causes the last row in the nested table to get ignored. We can avoid Greg's error handling workaround if we include another If statement to test for shorter row lengths and also change the method to determine whether moving selection down is still inside the table under review.

Code:

Sub Tables2Levels()
  Dim aTbl As Table, aTblinner As Table
  Dim lngView As Long
  lngView = ActiveDocument.ActiveWindow.View
  ActiveDocument.ActiveWindow.View = wdNormalView
  For Each aTbl In ActiveDocument.Tables
    SplitVertMergeCells aTbl
    For Each aTblinner In aTbl.Tables 'process the first level nested tables as well
      SplitVertMergeCells aTblinner
    Next aTblinner
  Next aTbl
  ActiveDocument.ActiveWindow.View = lngView
End Sub

Sub SplitVertMergeCells(aTbl As Table)
  Dim aCell As Cell, i As Integer, aRng As Range
  Dim iRow As Integer, iCol As Integer, iSplit As Integer
  If Not aTbl.Uniform Then
    For Each aCell In aTbl.Range.Cells
      If aCell.RowIndex = aTbl.Rows.Count Then Exit For
      Set aRng = aCell.Range
      aRng.Select
      Selection.MoveDown Unit:=wdLine, Count:=1
      If Selection.Range.End < aTbl.Range.End Then
        If Selection.Information(wdAtEndOfRowMarker) Then 'table has inconsistent row lengths
          iSplit = 1
        Else
          iSplit = Selection.Cells(1).RowIndex - aRng.Cells(1).RowIndex
        End If
      Else
        iSplit = aTbl.Rows.Count - aRng.Cells(1).RowIndex + 1
      End If
      If iSplit > 1 Then aCell.Split NumRows:=iSplit
    Next aCell
  End If
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Format tables with vertically merged cells	jeffreybrown	Word VBA	2	01-16-2019 03:23 PM
Unmerging vertically merged cells	kilroy	Word VBA	5	01-12-2018 12:54 PM
VBA color of visible gridlines of tables word (with some merged cells in first rows)	Alvaro.passi	Word VBA	0	07-18-2017 09:11 AM
Overcome issues in tables with vertically merged cells	rocky2	Word VBA	12	12-22-2016 03:03 AM
Combining 2 tables into 1 and use Table2's column widths (hoping for workaround dealing merged cells	CodingGuruInTraining	Word VBA	24	10-07-2015 07:48 PM