Copying charts from all Excel worksheets onto Powerpoint slides

[waqar.b85]

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

[duongduythao]

Me too. I am doing project and make power point need to copy some excel information through but not?

[JKwan]

this will cycle all worksheets within the active workbook

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
    Dim WB As Workbook
    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
    
    Set WB = ThisWorkbook
    For Each WS In WB.Worksheets
        MsgBox WS.Name
        '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
    Next WS
    Set WS = Nothing
    Set WB = Nothing
    Set activeSlide = Nothing
    Set newPowerPoint = Nothing
    Set pptPres = Nothing
End Sub