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

Answer 1

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