OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy

Function GetRowOverFlowIndex(oShape As Shape, oPres As Presentation) As Long
Dim Index As Long
Dim sngSldHeight As Single
Dim sngCurrHeight As Single

sngSldHeight = 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

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.
        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
End Sub

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

To test this code:

1. Create a table with 10 rows such some of the rows are overflow out of the slide area.

2. Select the table shape.

3. Run the SplitTable macro   

Conclusion:
1. Note this does not work with PPT 2007. Tables are broken in the object model in PPT 2007.
2. This examples works on the current shape selection in PowerPoint, you can easily extend it to work on all the tables in the presentation.