I'm tring to split a table if the table overflows the slide. I found some code that I modified slightly.


But when I try to add a row on the new table to copy the header from the original table I get an error.


If I add the line:


 oTableShape.Table.Rows.Add BeforeRow:=1

after the final next in the CopyToNewTable routine, I get an error at:


oSourceShape.Table.cell(RowIndex + I - 1, J).Shape.textFrame.textRange.Copy

which is a couple of lines above. The error is:


Method 'Copy' of object ' Textrange' failed.
If I delete it, the add before, it works fine.


Code follows.


Thanks in advance

Sub SplitTable()
Dim RowIndex As Long
Dim oShp As Shape
Dim oSld As slide
Dim i As Long


Set oShp = ActiveWindow.Selection.ShapeRange(1)


'Check if the selected shape is a table.
If Not oShp.HasTable Then
    MsgBox "This is not a table.", vbExclamation
    Exit Sub
End If


'Get the row at which table moves off the slide
RowIndex = GetRowOverFlowIndex(oShp, ActivePresentation)


'If no rows are out of slide, just get out otherwise process it
If RowIndex > 0 Then
   'Add a new slide for the a new table
   Set oSld = ActivePresentation.Slides.Add(oShp.Parent.SlideIndex + 1, oShp.Parent.Layout)
   'Now copy the rows to the new table.
   Call CopyToNewTable(oSld, oShp, RowIndex)


'Delete the rows from the original table
   For i = oShp.Table.Rows.Count To RowIndex Step -1
      oShp.Table.Rows(i).Delete
   Next
End If
End Sub
Function GetRowOverFlowIndex(oShape As Shape, oPres As Presentation) As Long
Dim Index As Long
Dim sngSldHeight As Single
Dim sngCurrHeight As Single


sngSldHeight = txDrawAreaTop + txDrawAreaHeight ' oPres.PageSetup.SlideHeight
'Get the top position of the shape on the slide
sngCurrHeight = oShape.Top
 
For Index = 1 To oShape.Table.Rows.Count


   'Check if the current height exceeds that of the slide height
   If sngCurrHeight + oShape.Table.Rows(Index).Height > sngSldHeight Then
      'We have found the row at which the table moves off the slide.
      GetRowOverFlowIndex = Index
      Exit Function
   Else
      'Increment the current height
      sngCurrHeight = sngCurrHeight + oShape.Table.Rows(Index).Height
   End If


Next
End Function


'' Copy overflow row onwards to a new slide
Sub CopyToNewTable(oSlide As slide, oSourceShape As Shape, RowIndex As Long)
Dim oTableShape As Shape
Dim i As Long
Dim j As Long


Set oTableShape = oSlide.Shapes.AddTable(oSourceShape.Table.Rows.Count - RowIndex + 1, _
      oSourceShape.Table.Columns.Count, _
      oSourceShape.left, _
      oSourceShape.Top, _
      oSourceShape.Width)


For i = 1 To oTableShape.Table.Rows.Count
   For j = 1 To oTableShape.Table.Columns.Count
    
   'Copy the text from the cell.
''//////////////////////////////////////////////////////////////////
''//  I get an error here when I add a row before or just by chance
''//////////////////////////////////////////////////////////////////
      oSourceShape.Table.cell(RowIndex + i - 1, j).Shape.textFrame.textRange.Copy
       
      'Paste it into the new location.
      oTableShape.Table.cell(i, j).Shape.textFrame.textRange.Paste
   Next
    
   oTableShape.Table.Rows(i).Height = oSourceShape.Table.Rows(RowIndex + i - 1).Height
Next
   
''/////////////////////////////////////////////////////////
''//  if I try to add a row and format it.  Sometimes the
''//  error occurs even if the code is commented
''/////////////////////////////////////////////////////////
  
''With oTableShape.Table.Rows
''   .Add Beforerow:=1
''End With
''
''For i = 1 To TableSource.Columns.Count
''   oTableShape.cell(1, i).Shape.textFrame.textRange.font.Color = _
''      oSourceShape.cell(1, i).Shape.textFrame.textRange.font.Color
''   oTableShape.cell(1, i).Shape.textFrame.textRange.font.Bold = _
''      oSourceShape.cell(1, i).Shape.textFrame.textRange.font.Bold
''   oTableShape.cell(1, i).Shape.textFrame.textRange.text = _
''      oSourceShape.cell(1, i).Shape.textFrame.textRange.text
''Next i


End Sub