#1
|
|||
|
|||
Finding Tables with Vertically Merged Cells
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. |
#2
|
|||
|
|||
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 |
#3
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#4
|
|||
|
|||
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. |
#5
|
|||
|
|||
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 |
#6
|
|||
|
|||
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. |
#7
|
|||
|
|||
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 |
#8
|
|||
|
|||
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 |
#9
|
|||
|
|||
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. |
#10
|
|||
|
|||
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! |
#11
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
Tags |
merged cells, tables |
Thread Tools | |
Display Modes | |
|
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 |