Delete all empty/unsed shapes from a presentation

Question

I've written the code to loop through a presentation's slides and then through it's shapes. If things are empty or invisible, I delete them.

However it's not delete all emply plave holders. It will do it on a second or third run.

    Sub RemoveEmptyShapes()

Dim slide As slide
Dim shp As Shape

For Each slide In ActivePresentation.Slides
    For Each shp In slide.Shapes
        If shp.Type = msoAutoShape Or shp.Type = msoTextBox Or shp.Type = msoPlaceholder Then
            If shp.Type = msoPlaceholder And shp.TextFrame2.TextRange.Text = "" Then
                shp.Delete
            ElseIf shp.Type <> msoPlaceholder And shp.Fill.Visible = False And shp.Line.Visible = False And shp.TextFrame2.TextRange.Text = "" Then
                shp.Delete
            End If
        End If
    Next shp
Next slide

End Sub

You have to iterate backward (from the end toward the beginning) when deleting from a list or collection. If you do it from start to end, you will skip items because you're removing things from the list/collection, moving items after the deleted one up toward the front. Write the operation out on paper to see how it happens. What you're basically doing is cutting off the branch you're standing on between yourself and the tree trunk. — Ken White, Apr 09 '23 at 03:14

score 4 · Answer 1 · answered Apr 09 '23 at 02:31

You are deleting shapes while you are still looping through them. The collection of shapes is modifying during the loop and this can cause issues.

You can fix that by changing the line For Each shp In slide.Shapes to For i = slide.Shapes.Count To 1 Step -1 and then accessing each shape using slide.Shapes(i):

Sub RemoveEmptyShapes()

    Dim slide As Slide
    Dim shp As Shape
    Dim i As Integer
    
    For Each slide In ActivePresentation.Slides
        For i = slide.Shapes.Count To 1 Step -1
            Set shp = slide.Shapes(i)
            If shp.Type = msoAutoShape Or shp.Type = msoTextBox Or shp.Type = msoPlaceholder Then
                If shp.Type = msoPlaceholder And shp.TextFrame2.TextRange.Text = "" Then
                    shp.Delete
                ElseIf shp.Type <> msoPlaceholder And shp.Fill.Visible = False And shp.Line.Visible = False And shp.TextFrame2.TextRange.Text = "" Then
                    shp.Delete
                End If
            End If
        Next i
    Next slide
    
End Sub

Oran G. Utan · Accepted Answer · 2023-04-27T18:12:20.327

You may also want to try with arrays, with the advantage of working almost instantly on a large number of slides. I split it in one Sub and one function, so you may change the range of slides it should work on.

Sub deleteShapesFromAllSlides()

Dim sldArr() As slide
Dim j As Long
    
    j = ActivePresentation.Slides.Count

    ReDim sldArr(ActivePresentation.Slides.Count)
    
        For j = 1 To UBound(sldArr)
                Call deleteShapes(ActivePresentation.Slides(j))
        Next j

End Sub

Sub deleteShapes(sl As PowerPoint.slide)

Dim shArr() As Long
Dim i As Long
Dim q As Long

    ReDim shArr(sl.Shapes.Count)

    For i = 1 To sl.Shapes.Count '- 1 not necessary to start from bottom
    
            If sl.Shapes(i).Type = msoAutoShape Or sl.Shapes(i).Type = msoTextBox Or sl.Shapes(i).Type = msoPlaceholder Then

                     If sl.Shapes.Range(i).TextFrame2.TextRange.Text = "" Then
                    
                        shArr(q) = i
                        q = q + 1

                    End If
                    
            ElseIf sl.Shapes(i).Type <> msoPlaceholder And sl.Shapes(i).Fill.Visible = False And sl.Shapes(i).Line.Visible = False Then
                    
                    If sl.Shapes(i).TextFrame2.TextRange.Text = "" Then

                        shArr(q) = i
                        q = q + 1
                    
                    End If
            End If
    Next i
    
    ReDim Preserve shArr(q - 1) '... but it's necessary to resize shArr because arrays have index 0, so the -1 is back :D
    
     sl.Shapes.Range(shArr).Delete

End Sub

Incredible @bradipo – Miguel de las Nieves Apr 27 '23 at 01:03 — Miguel de las Nieves, Apr 27 '23 at 01:03

Delete all empty/unsed shapes from a presentation

2 Answers2