Adding worksheet name to powerpoint slide title

d1e9v85

New Member
Joined
May 1, 2018
Messages
11
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.

Code:
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
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Tried to search the forum for something similar but could not find.
Would appreciate any help

thanks
 
Upvote 0
You could try something like this.
Code:
activeSlide.Shapes.Title.TextFrame.TextRange.Text = ActiveSheet.Name
 
Upvote 0
Thanks Norie,

I tried that in the code. but it gives me a runtime error
"Method 'Title' of object 'Shapes' failed."
 
Upvote 0
Do the slides you are creating have titles?
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,208
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top