Splitting Tables containing Merged Cells

[bpike]

Hi all,



I'm hoping someone can help me with splitting tables that contain merged cells?

My macro works fine in a regular table, however, if there are any merged cells present I receive a Run-time error '-2147024808 (80070057)': Object has been deleted.

My code is as follows:

Sub SplitTable()

Dim oTbl As Word.Table, oRow As Row, oCell As Cell


For Each oTbl In ThisDocument.Tables
      
    n = 1
        Do While n > 0
        For Each oCell In oTbl.Range.Cells
        If oCell.Range = "Tree Number" & Chr(13) & Chr(7) Then n = oCell.RowIndex
        Next
        If n = 1 Then Exit Do
        oTbl.Split (n)
        n = 1
     
        Loop

Next oTbl

End Sub

Any workaround will be much appreciated.

[macropod]

Sub SplitTables()
Application.ScreenUpdating = False
Dim t As Long, c As Long
With ActiveDocument
  On Error Resume Next
  For t = .Tables.Count To 1 Step -1
    With .Tables(t).Range
      For c = .Cells.Count To 1 Step -1
        With .Cells(c)
          If .RowIndex > 1 Then
            If Split(.Range.Text, vbCr)(0) = "Tree Number" Then .Range.InsertBreak (wdColumnBreak)
          End If
        End With
      Next
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

[bpike]

Perfect, Thank you for your help.

[bpike]

I'm finding that I receive Run-time error 5941 if there are more than 2 rows containing the text 'Tree Number'. As if the code only handles the error once. I need the sub-routine to be able to split the table as many times as it finds the text. Hope this makes sense.

Thanks.

[Guessed]

I suspect the runtime error is coming from vertically merged cells rather than multiple instances of Tree Number. Can you confirm that your tables have no vertically merged cells?

To continue working on the same table, this change to Paul's code appears to work

Sub SplitTables()
  Application.ScreenUpdating = False
  Dim t As Long, c As Long
  With ActiveDocument
    On Error Resume Next
    For t = .Tables.Count To 1 Step -1
RestartTable:
      With .Tables(t).Range
        For c = .Cells.Count To 1 Step -1
          With .Cells(c)
            If .RowIndex > 1 Then
              If Split(.Range.Text, vbCr)(0) = "Tree Number" Then
                .Range.InsertBreak (wdColumnBreak)
                GoTo RestartTable
              End If
            End If
          End With
        Next
      End With
    Next
  End With
  Application.ScreenUpdating = True
End Sub

[bpike]

Yes, I am indeed working with tables contaning merged vertical cells.

Your revised code has fixed my problem. Thank you.

[macropod]

Alternatively:

Sub SplitTables()
Application.ScreenUpdating = False
Const StrFnd As String = "Tree Number"
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = StrFnd
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = True
  End With
  Do While .Find.Execute
    If .Information(wdWithInTable) = True Then
      With .Cells(1)
        If .RowIndex > 1 Then
          If Split(.Range.Text, vbCr)(0) = StrFnd Then .Range.InsertBreak (wdColumnBreak)
        End If
      End With
    End If
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub

This should also be faster than looping through all cells in all tables.

[bpike]

This code does perform the process a lot quicker. Thank you both for your input, I tried for a week with little success before joining your forum.

Cheers.