going through multiple worksheets and copying all charts from them

[d1e9v85]

Hello experts,

I have the code below that works well to export excel graphs onto powerpoint. But where I am stuck is that it only exports the graphs from the active worksheet.

How can I make it cycle through all the whole workbook and then export the graphs sheet by sheet?

Thanks

Option Base 1


Sub CreatePowerPoint()


'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


 '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 i = 1 To ActiveSheet.ChartObjects.Count
        Set cht = ActiveSheet.ChartObjects(i)
            
    '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:=ppPasteMetafilePicture).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 = 50
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
    ElseIf chartNum = 1 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 528
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
    ElseIf chartNum = 2 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
    Else
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 528
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
    End If


    newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 300
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 350


    Next


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


End Sub

 

[Roderick_E]

sorry, someone smarter than me is bound to come along

 

[d1e9v85]

Thanks Roderick. Appreciate your help.

Will update this thread if i have any updates

 

[areed1192]

I hope you don't mind but I went ahead and changed some of your code so that way it would export all the charts we specify in a workbook.

Now when I was looking through your code, it appeared that you wanted to export select charts from within the workbook not all of them. That being said I went ahead and wrote this code assuming you wanted to export select charts across your workbook.

Here's the code:

Sub CreatePowerPoint()


    'Declare PowerPoint Variables
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim pptPres As PowerPoint.Presentation
    Dim PPTShape As PowerPoint.Shape
    
    'Declare Excel Variables
    Dim WrkSht As Worksheet
    Dim cht As ChartObject
    Dim ChtArray As Variant


    '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
    
    'Make PowerPoint Visible
    newPowerPoint.Visible = True
    
    'Open the file with the presentation.
    Set pptPres = newPowerPoint.Presentations.Open(Filename:=strFileToOpen, ReadOnly:=msoFalse)




    'Backup is that if there is no presentation then make one.
    If newPowerPoint.Presentations.Count = 0 Then
       newPowerPoint.Presentations.Add
    End If
    
    'Define the charts we want to export along with their corresponding dimensions
    ChtArray = Array(Sheet1.ChartObjects(1), Sheet1.ChartObjects(2), Sheet1.ChartObjects(3))
    LeftArray = Array(50, 528, 50, 528)
    TopArray = Array(70, 70, 300, 300)


'Loop through all the worksheets in the ACTIVE WORKBOOK
For Each WrkSht In ActiveWorkbook.Worksheets
    For x = LBound(ChtArray) To UBound(ChtArray)
        
        'Create a reference to the chart we want to export
        Set cht = Nothing 'reset
        Set cht = ChtArray(x)
        
        'Create a new slide in the presentation
        newPowerPoint.ActivePresentation.Slides.Add pptPres.Slides.Count + 1, ppLayoutTitleOnly
        
        'Set a reference to the active slide.
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
        
        'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
        
        'Copy the chart, paste the chart, then select the chart.
        cht.Copy
        activeSlide.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
        Set PPTShape = activeSlide.Shapes(activeSlide.Shapes.Count)
        
        'Set the dimensions of the charts
        With PPTShape
            .Left = LeftArray(x)
            .Top = TopArray(x)
            .Height = 300
            .Width = 350
        End With


    Next x
Next WrkSht


'Release Objects from memory
Set activeSlide = Nothing
Set newPowerPoint = Nothing
Set pptPres = Nothing


End Sub

I want to make a few notes about my code, instead of trying to calculate the chart I was on and then use that "Chart Number" to determine the dimensions of the chart I chose to put all the information in an array for you.

You can change that array as you wish but ideally, this will make your code a little easier to manipulate and manage. Also, it saves you from having to calculate all that extra information which we always know is never fun.

Please feel free to adjust the code as you wish and if you need any help after you adjust please feel free to reach back out.

If you want more information on how to export charts across your workbook you can take a look at my YouTube video where I walk through some examples of how to do it. It was a common request so I decided to make a video on it.

This is exporting multiple charts.
https://youtu.be/DOaBtYMCCEM

This is setting dimensions of the objects we paste.
https://youtu.be/TyZ47qI0NkQ

FULL DISCLOSURE THIS IS MY PERSONAL YOUTUBE CHANNEL

 

[areed1192]

Realized there was an error in my code, you can take out the part where we loop through all the worksheets in our ActiveWorkbook this is unnecessary as we specify the sheet we are working within the array.

So please remove this line:

'Loop through all the worksheets in the ACTIVE WORKBOOK
For Each WrkSht In ActiveWorkbook.Worksheets