Delete everything but the title

[cwojtak]

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!


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

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

[Paul_Hossler]

Delete bottoms-up


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

[cwojtak]

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

[cwojtak]

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

[John Wilson]

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




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

[cwojtak]

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!


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

[Paul_Hossler]

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




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

[John Wilson]

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

[cwojtak]

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?


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

[John Wilson]

Maybe (not quite sure what you mean)


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

[cwojtak]

Exactly what I was looking for, thank you John!