Delete everything but the title

I have a VBA to copy my selected range in excel and paste it into my current PPT slide. I am trying to add a process to the code that deletes everything in the active slide except for the title prior to pasting. Here is what I have but it is very inconsistent.

Sometimes it deletes the title, sometimes it deletes the previously pasted range, sometimes it works perfectly. Very confused why it is so inconsistent.

Any input would be greatly appreciated!

Code:

---

Dim mySlide As Object
Set mySlide = PowerPointApp.ActiveWindow.View.Slide

  For Each Shape In mySlide.Shapes      If Shape.Type <> msoPlaceholder Then Shape.Delete
  Next

---

Delete bottoms-up

Code:

---

For i = mySlide.Shapes.count to 1 Step -1
    If mySlide.Shapes(i).Type = msoPlaceHolder Then 

mySlide.Shapes(i).Delete
Next i

---

Thanks for the quick response Paul! I like your approach on that. Unfortunately I am getting "compile error: next without for"

When I take the if statement out it works but it deletes the title as well

What do you mean by "Title"? If you mean Text in a Title Placeholder?

Code:

---


Sub zapTitle()


Dim osld As Slide
Set osld = ActiveWindow.Selection.SlideRange(1)
Dim L As Long
For L = osld.Shapes.Count To 1 Step -1
If osld.Shapes(L).Id <> osld.Shapes.Title.Id Then
osld.Shapes(L).Delete
End If
Next L
End Sub

---

Your Advice worked perfect! Thank you John! If interested in the overall goal -

I have about 60 Tables in Excel that I put into different powerpoints each month. All of the slides I am working with have a title, a table, and some (not all) have bullet points in text boxes. I am writing a code that allows me to highlight a table in excel, press the macro shortcut key and produce the following actions

- Delete all of the content in the selected slide excluding the title box and words in the title box
- Paste the selected table from excel into the selected slide

For reference, here is my full code. Please let me know if you have any recommendations to make it more concise!

Code:

---

Sub ExcelRangeToPowerPoint()

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Slide
Dim myShape As Object


'Copy Range from Excel
  Set rng = Selection
  rng.Copy


'Create an Instance of PowerPoint
  On Error Resume Next
   
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
   
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
   
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


  Application.ScreenUpdating = False
 
  Set myPresentation = PowerPointApp.ActivePresentation
 
  Set mySlide = PowerPointApp.ActiveWindow.Selection.SlideRange(1)
 
  Dim L As Long
  For L = mySlide.Shapes.Count To 1 Step -1
  If mySlide.Shapes(L).ID <> mySlide.Shapes.Title.ID Then
  mySlide.Shapes(L).Delete
  End If
  Next L


'Paste to PowerPoint and position
  mySlide.Shapes.Paste
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
 
    'Set position:
      myShape.Left = 66
      myShape.Top = 152


'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate


'Clear The Clipboard
  Application.CutCopyMode = False
 
End Sub

---

Quote:

---

Originally Posted by cwojtak

Thanks for the quick response Paul! I like your approach on that. Unfortunately I am getting "compile error: next without for"

---

Forum software sometimes breaks lines where it's not intended

Code:

---

For i = mySlide.Shapes.count to 1 Step -1
    If mySlide.Shapes(i).Type = msoPlaceHolder Then  mySlide.Shapes(i).Delete
Next i

---

Edit -- go with John's since you have a lot more going on that just deleting some shapes on a slide and it will be easier to expand to meet your need

Paul's advice to loop in reverse if you are deleting anything is good (vital even)!

Adding to my question, please let me know if I need to start a new thread but I feel this relates. I am now trying to get the code to move to the next slide now. The code below works but I am struggling to incorporate it at the end of the complete sub (Shown in reply #6). Any input?

Code:

---

Dim rng As RangeDim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Slide
Dim myShape As Object


'Copy Range from Excel
  Set rng = Selection
  rng.Copy


'Create an Instance of PowerPoint
  On Error Resume Next
   
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
   
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
   
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


  Application.ScreenUpdating = False
 
  Set myPresentation = PowerPointApp.ActivePresentation
  Set mySlide = PowerPointApp.ActiveWindow.Selection.SlideRange(1)

 
  a = mySlide.SlideIndex
  a = a + 1
  myPresentation.Slides(a).SelectEnd Sub

---

Maybe (not quite sure what you mean)

Code:

---

Sub ExcelRangeToPowerPoint()

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object




'Copy Range from Excel
  Set rng = Selection
  rng.Copy
'Create an Instance of PowerPoint
  On Error Resume Next


    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
   
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
   
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If
  On Error GoTo 0
  Application.ScreenUpdating = False
 
  Set myPresentation = PowerPointApp.ActivePresentation
 
  Set mySlide = PowerPointApp.ActiveWindow.Selection.SlideRange(1)
 
  Dim L As Long
  If mySlide.Shapes.HasTitle Then
    For L = mySlide.Shapes.Count To 1 Step -1
  If mySlide.Shapes(L).ID <> mySlide.Shapes.Title.ID Then
  mySlide.Shapes(L).Delete
  End If
    Next L
  Else
  mySlide.Shapes.Range.Delete
  End If
'Paste to PowerPoint and position
  mySlide.Shapes.Paste
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
 
    'Set position:
      myShape.Left = 66
      myShape.Top = 152
' Next slide
If mySlide.slideindex < myPresentation.slides.Count Then
myPresentation.slides(mySlide.slideindex + 1).Select
End If
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate


'Clear The Clipboard
  Application.CutCopyMode = False
 
End Sub

---

Exactly what I was looking for, thank you John!