View Single Post
 
Old 07-17-2020, 10:14 AM
gmaxey gmaxey is offline Windows 10 Office 2016
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,428
gmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the rough
Default

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
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote