Adding worksheet name to powerpoint slide title

[d1e9v85]

Hello Experts,

I have the following code which loops through an Excel Workbook and copies all the charts from each worksheet and then pastes into a new power point slide, max of 4 charts per slide.

The modification I would like to make is to add a title to each ppt slide and paste the worksheet name onto the ppt slide title.

Option Base 1


Sub ChartsToSlide()


'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject
    Dim pptPres As PowerPoint.Presentation
    Dim ws As Worksheet


 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0


'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    strFileToOpen = Application.GetOpenFilename(FileFilter:="Powerpoint Files *.pptx (*.pptx),")
    If strFileToOpen = False Then Exit Sub
    Set newPowerPoint = New PowerPoint.Application
    newPowerPoint.Visible = True
    Set pptPres = newPowerPoint.Presentations.Open(Filename:=strFileToOpen, ReadOnly:=msoFalse)


    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If


'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
    For i = 1 To ActiveSheet.ChartObjects.Count
        Set cht = ActiveSheet.ChartObjects(i)
        
    ActiveChart.PlotArea.Select
    Application.CommandBars("Format Object").Visible = False
    ActiveWindow.SmallScroll Down:=18
    ActiveChart.ChartArea.Select
    ActiveWindow.SmallScroll Down:=-18
    
    With ActiveSheet.Shapes(i).Line
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Visible = msoTrue
        .Weight = 1
    End With
    ActiveSheet.Shapes(i).Line.Style = msoLineSingle
    ActiveChart.Parent.RoundedCorners = True


            
    'Add a new slide where we will paste the chart
    chartNum = (i - 1) Mod 4
    If chartNum = 0 Then
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
    End If




       newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)


    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=Picture).Select


    'Set the title of the slide the same as the title of the chart
        'activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text


    'Adjust the positioning of the Chart on Powerpoint Slide
  If chartNum = 0 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 8
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
    ElseIf chartNum = 1 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 479
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
    ElseIf chartNum = 2 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 8
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 301
    Else
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 479
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 301
    End If


    newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 230
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 470


    Next
Next
    
Set activeSlide = Nothing
Set newPowerPoint = Nothing
Set pptPres = Nothing


End Sub

Any help would be greatly appreciated

 

[d1e9v85]

Tried to search the forum for something similar but could not find.
Would appreciate any help

thanks

 

[Norie]

You could try something like this.

activeSlide.Shapes.Title.TextFrame.TextRange.Text = ActiveSheet.Name

 

[d1e9v85]

Thanks Norie,

I tried that in the code. but it gives me a runtime error
"Method 'Title' of object 'Shapes' failed."

 

[Norie]

Do the slides you are creating have titles?

 

[d1e9v85]

no. just blank ppt slides