I have the following code I hacked together from various sites I researched that copies an Excel chart and range and:
A. If there is an active PowerPoint presentation, creates a new slide as the 1st slide and pastes the objects into it, or
B, If no presentation is opened, creates one, adds a slide, and pastes the objects into it.
The code further formats the slide as a title+content layout.
Although the code may not be the best, it works for me except I'm trying to do the following that I can't figure out:
1. Place the new slide at the current slide location of the active presentation, not always as the 1st slide.
2. Make the layout format as title only rather than title+content.
3. Add text to the title inclusive of removing the default "Click to add title".
My code is:
Option Explicit
-----------------
Sub Slide()
Dim pptApp As Object ' PowerPoint.Application
Dim pptPres As Object ' PowerPoint.Presentation
Dim pptSlide As Object ' PowerPoint.Slide
Dim pptShape As Object ' PowerPoint.Shape
Dim pptShpRng As Object ' PowerPoint.ShapeRange
Dim lActiveSlideNo As Long
' figure out what slide to paste on
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
On Error Resume Next
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 2)
Else
If pptApp.Presentations.Count > 0 Then
Set pptPres = pptApp.ActivePresentation
Set pptSlide = pptPres.Slides.ActiveWindow.View.Slide.SlideNumber
Set pptSlide = pptPres.Slides.Add(1, 2)
Else
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 2)
End If
End If
' copy and paste chart
Worksheets("Chart").ChartObjects("Chart 2").Copy
With pptSlide
.Shapes.Paste
Set pptShape = .Shapes(.Shapes.Count)
Set pptShpRng = .Shapes.Range(pptShape.Name)
End With
' align chart on slide
With pptShpRng
.Align msoAlignMiddles, True ' top-bottom
.Left = 365
.LockAspectRatio = msoTrue
.Height = 300
End With
' copy and paste range
Worksheets("Chart").Range("B22:D28").Select
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlPicture
With pptSlide
.Shapes.Paste
Set pptShape = .Shapes(.Shapes.Count)
Set pptShpRng = .Shapes.Range(pptShape.Name)
End With
' align range on slide
With pptShpRng
'.Align msoAlignCenters, True ' left-right
'.Align msoAlignMiddles, True ' top-bottom
.Left = 75
.Top = 260
.LockAspectRatio = msoTrue
.Height = 124
End With
Worksheets("Chart").Range("B30").Select
End Sub
Bookmarks