Split table

[juanbolas]

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