VBA PowerPoint - Move Shapes When Table Rows Are Deleted

[Huey72]

Hi everyone. I am trying to figure out the VBA code to move a series of pictures/shapes up, when rows are deleted in a table on a PowerPoint slide i.e., when the slide is created, the pictures/shapes are aligned to the top of a table row/cell, and when a table row is deleted, I want the pictures/shapes on that row to also be deleted, and I want the text and pictures from the rows below to move up. By default, deleting the rows moves the text up as desired, but nothing happens with the pictures/shapes, so they become misaligned.

Here's the code and function I'm currently using - it's a work in progress and partially working, but I can't figure out how to move the pictures up to re-align them with their associated rows. The code and function is splitting a table that overruns the size of the slide, by copying the slide, and deleting the excessive rows from the first slide, and the duplicate rows on the second slide....it's the second slide I'm having trouble with.

Thanks for your help with this!

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

sngSldHeight = 500
'Get the top position of the shape on the slide
sngCurrHeight = oshp.Top
 
For Index = 1 To oshp.Table.Rows.Count

    'Check if the current height exceeds that of the slide height
    If sngCurrHeight + oshp.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 + oshp.Table.Rows(Index).Height
    End If
Next

End Function

Sub SplitTable()
Dim RowIndex    As Long
Dim oshp        As Shape
Dim oshps        As Shapes
Dim osld        As Slide
Dim newSlide    As Slide
Dim oTableShape As Shape
Dim i           As Long
Dim j           As Long
Dim oshppic As Shape

Set osld = Application.ActiveWindow.View.Slide

For Each oshp In osld.Shapes
    If oshp.Type = 19 Then 'msoTable Then
        oshp.Select
        Set oshp = ActiveWindow.Selection.ShapeRange(1)
        GoTo foundit
    End If
Next oshp

foundit:

'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
    
    Set newSlide = osld.Duplicate()(1)
    
    'Delete the excessive rows from the original table
    For i = oshp.Table.Rows.Count To RowIndex Step -1
    
        For Each oshppic In osld.Shapes
            If oshppic.Top = oshp.Table.Cell(i, 1).Shape.Top Then
                oshppic.Delete
            End If
        Next oshppic
        
        oshp.Table.Rows(i).Delete 'delete the table row
    Next i
   
    
    'Delete the 'base' rows from the original slide - on the new slide
    newSlide.Select
    
    For Each oshp In newSlide.Shapes
    If oshp.Type = 19 Then 'msoTable Then
        oshp.Select
        Set oshp = ActiveWindow.Selection.ShapeRange(1)
        GoTo foundit2
    End If
    Next oshp
    
foundit2:
    
    For i = RowIndex - 1 To 5 Step -1
        For Each oshppic In newSlide.Shapes
            If oshppic.Top = oshp.Table.Cell(i, 1).Shape.Top Then
                oshppic.Delete
                oshp.Table.Cell(i, 4).Shape.TextFrame.TextRange.Delete
                oshp.Table.Cell(i, 9).Shape.TextFrame.TextRange.Delete
                oshp.Table.Cell(i, 10).Shape.TextFrame.TextRange.Delete
                oshp.Table.Cell(i, 11).Shape.TextFrame.TextRange.Delete
            End If
        Next oshppic
    Next i
    
    'move the values up
    For i = RowIndex - 1 To 5 Step -1
                    
        For Each oshppic In newSlide.Shapes
            If oshppic.Top = oshp.Table.Cell(i, 1).Shape.Top Then
                oshppic.Delete
            End If
        Next oshppic
        
        newSlide.Shapes.Item(a).Table.Rows(i).Delete
    Next
    
End If

End Sub

 

[Huey72]

Hi everyone, I figured out an approach that works. By assigning names to the shapes/pictures when I add them to the slide, I can use that name to delete the shape based on the deleted record/name. For reference if helpful to anyone else, here's the code I landed on.

Option Explicit

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

sngSldHeight = 500
'Get the top position of the shape on the slide
sngCurrHeight = oTbl.Top
 
For Index = 1 To oTbl.Table.Rows.Count

    'Check if the current height exceeds that of the slide height
    If sngCurrHeight + oTbl.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 + oTbl.Table.Rows(Index).Height
    End If
Next

End Function

Sub SplitTable()
Dim RowIndex        As Long
Dim oShp            As Shape
Dim oSld            As Slide
Dim oTbl            As Shape
Dim newSlide        As Slide
Dim i               As Long

Set oSld = Application.ActiveWindow.View.Slide 'set the active slide variable

For Each oTbl In oSld.Shapes 'For each shape in the slide
    If oTbl.Type = msoTable Then 'If the shape is a Table
        Set oTbl = oTbl 'ActiveWindow.Selection.ShapeRange(1) 'set the table variable to the found table
        GoTo foundit 'exit the loop
    End If
Next oTbl

foundit:

'Use the function to specify the row number to cut off the table
RowIndex = GetRowOverFlowIndex(oTbl, ActivePresentation)

'If no rows are out of specified slide range, do nothing, otherwise continue
If RowIndex > 0 Then
    
    Set newSlide = oSld.Duplicate()(1) 'Duplicate the slide with the excessive rows and assign the variable
    
    'Delete the excessive rows from the original slide/table
    For i = oTbl.Table.Rows.Count To RowIndex Step -1 'loop backwards from the last row in the table, to the rowindex/cutoff row
    
        'First delete the shapes
        For Each oShp In oSld.Shapes 'For each shape in the slide
            If oShp.Name = "oShp_" & oTbl.Table.Cell(i, 4).Shape.TextFrame.TextRange.Text Then 'If the shape name matches the associated cell text
                oShp.Delete 'delete the shape
            End If
        Next oShp
        
        oTbl.Table.Rows(i).Delete 'delete the table row
    Next i
   
    'Delete the duplicate rows (from the original slide) on the new slide
    newSlide.Select 'select the new slide
    
    For Each oTbl In newSlide.Shapes 'For each shape in the slide
        If oTbl.Type = msoTable Then 'If the shape is a Table

            Set oTbl = oTbl 'ActiveWindow.Selection.ShapeRange(1) 'set the table variable to the found table
            
            For i = RowIndex - 1 To 5 Step -1 'loop backwards from the rowindex/cutoff row - to the first row of values (these are the duplicate rows to delete)
                For Each oShp In newSlide.Shapes 'For each shape in the slide
                    If oShp.Name = "oShp_" & oTbl.Table.Cell(i, 4).Shape.TextFrame.TextRange.Text Then 'If the shape name matches the associated cell text
                        oShp.Delete 'delete the shape
                        oTbl.Table.Rows(i).Delete 'delete the table row
                    End If
                Next oShp
            Next i
            
            For i = oTbl.Table.Rows.Count - 1 To 5 Step -1 'loop backwards from the last table row - to the first row of values (these are the remaining rows)
                For Each oShp In newSlide.Shapes 'For each shape in the slide
                    If oShp.Name = "oShp_" & oTbl.Table.Cell(i, 4).Shape.TextFrame.TextRange.Text Then 'If the shape name matches the associated cell text
                        oShp.Top = oTbl.Table.Cell(i, 1).Shape.Top 'Move the shape alignment to match the Top of the found text
                    End If
                Next oShp
            Next i
        End If
    Next oTbl
End If

End Sub