VBA code to copy data into powerpoint 2010 chart from excel 2010?

[josephjcota]

VBA code to copy data into powerpoint 2010 chart from excel 2010?
I am trying to automate the process of populating the charts in the powerpoint (office 2010). Can anybody please help with the VBA code to

Copy data in excel > select the template chart in the powerpoint > open the data sheet > paste the copied data and close>loop

I am using office 2010, so please provide codes that work in office 2010.

I initially tried to create charts in excel and paste it in the powerpoint with the link and update the link whenever we get new data. However, after pasting couple of charts it becomes very slow. Since I have more than 200 charts, updating all the charts using VBA is my only option.

 

[Derek Brown]

Hello and welcome to The Board.
Not exactly what you were asking for but you should be able to make use of it.
Important: Always test on a copy of the workbook(s).
The following code will copy Excel Charts to PowerPoint.
It was originally written for Excel 2003 but a quick test indicates that it may be OK for Excel 2010.
Applying a template to a new existing presentation was diffrerent in Office 2003 but you may find that the following will help you:
http://www.dummies.com/how-to/conte...nt-2007-template-to-an-exis.navId-405688.html

Option Explicit
Sub CopyChartsToPowerPoint()
'
'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long
'
'Powerpoint Application objects declaration
' You need to add a reference (Tools | References) to the Microsoft PowerPoint nn.nn Object Library
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
'
On Error GoTo Error_Para
'
    'Create a new Powerpoint session
    Set pptApp = CreateObject("PowerPoint.Application")
    '
    pptApp.Visible = msoTrue
    'Create a new presentation
    Set pptPres = pptApp.Presentations.Add
    Set pptPres = pptApp.ActivePresentation
    '
    pptApp.ActiveWindow.ViewType = ppViewSlide
'
    lngSlideKount = 0
    For Each ws In ActiveWorkbook.Worksheets
      'Verify if there is a chart object to transfer
      If ws.ChartObjects.Count > 0 Then
        For Each objChartObject In ws.ChartObjects
          Set objChart = objChartObject.Chart
          'ppLayoutBlank = 12
          Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
          pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
          With objChart
           'Copy chart object as picture
            objChart.CopyPicture xlScreen, xlBitmap, xlScreen
            'Paste copied chart picture into new slide
            pptSld.Shapes.Paste.Select
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
          End With
          lngSlideKount = lngSlideKount + 1
        Next objChartObject
      End If
    Next ws
    ' Now check CHART sheets:
    For Each objCht In ActiveWorkbook.Charts
        'ppLayoutBlank = 12
        Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
        pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
        With objCht
            'Copy chart object as picture
            .CopyPicture xlScreen, xlBitmap, xlScreen
            'Paste copied chart picture into new slide
            pptSld.Shapes.Paste.Select
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        End With
        lngSlideKount = lngSlideKount + 1
    Next objCht
    '
    'Activate PowerPoint application
    pptApp.ActiveWindow.ViewType = ppViewNormal
    pptApp.Visible = True
    pptApp.Activate
    If lngSlideKount > 0 Then
        If lngSlideKount = 1 Then
            MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
        Else
            MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
        End If
    End If
    GoTo Exit_Para
Error_Para:
    MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & _
        Err.Description & vbCrLf & vbCrLf & _
        "copying charts to PowerPoint", vbOKOnly + vbCritical, "Error"
Exit_Para:
    On Error Resume Next
    Set ws = Nothing
    Set objChart = Nothing
    Set objChartObject = Nothing
    Set pptSld = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

 

[Derek Brown]

I have been asked to provide a code change to 'link' the excel charts to PowerPoint instead of coping the charts as pictures.
Here is the code to replace the "similar" section of code previously given:

    lngSlideKount = 0
    For Each ws In ActiveWorkbook.Worksheets
      'Verify if there is a chart object to transfer
      If ws.ChartObjects.Count > 0 Then
        For Each objChartObject In ws.ChartObjects
          Set objChart = objChartObject.Chart
          'ppLayoutBlank = 12
          Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
          pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
          With objChart
            '
            objChart.ChartArea.Copy '<=====
            pptSld.Shapes.PasteSpecial(Link:=msoCTrue).Select  ' <=====
            '
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
          End With
          lngSlideKount = lngSlideKount + 1
        Next objChartObject
      End If
    Next ws
    ' Now check CHART sheets:
    For Each objCht In ActiveWorkbook.Charts
        'ppLayoutBlank = 12
        Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
        pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
        With objCht
            '
            .ChartArea.Copy ' <=====
            pptSld.Shapes.PasteSpecial(Link:=msoCTrue).Select  ' <=====
            '
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
            pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        End With
        lngSlideKount = lngSlideKount + 1
    Next objCht

The changed lines are highlighted with "<=====".

This seems to work OK for me using Office 2010 but note that it has not been extensively tested.

 

[ADELAF]

Hi there! Thank you for your help! It is exactly what I needed!

Anne

 

[Derek Brown]

That's OK, Anne - pleased it works OK for you.
Until I received your PM, I had not had a need to link (only paste) pictures so I may even find it useful myself in the future.

 

[nmoiseff]

This is absolutely fantastic! I have been trying to find code similiar to this for a long time.

Is there a way to modify this code so that it copies a range of cells in each worksheet instead of just the chart objects?

I ask this because I want to copy and paste both a chart and a table (right below the chart) and paste it into powerpoint. The range of cells that includes both the chart and the table would be J1:Y35.

 

[Derek Brown]

Hello and welcome to The Board.
Here is an example of what you want to do - you will need to change the name of the worksheet and the range of cells that you want to copy to PowerPoint.
It works for me using Office 2010.

Sub CopyChartsToPowerPoint3()
'
'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long
'
'Powerpoint Application objects declaration
' You need to add a reference (Tools | References) to the Microsoft PowerPoint nn.nn Object Library
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
'
On Error GoTo Error_Para
'
    'Create a new Powerpoint session
    Set pptApp = CreateObject("PowerPoint.Application")
    '
    pptApp.Visible = msoTrue
    'Create a new presentation
    Set pptPres = pptApp.Presentations.Add
    Set pptPres = pptApp.ActivePresentation
    '
    pptApp.ActiveWindow.ViewType = ppViewSlide
'
    lngSlideKount = 0
    'ppLayoutBlank = 12
    Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
    pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
' ======================================================================
' Changed code in this Message Board post:
' This code needs to be tidied
' e.g. Dim wb as Workbook
' Set wb = ThisWorkbook
' Set ws = wb.Worksheets("MySheet")
' etc.
' ======================================================================
' select sheet containing data to be copied to PowerPoint:
    Sheets("MySheet").Select
' select cells to be copied to PowerPoint:
    Range("A1:I24").Select
' copy cells:
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' past to PowerPoint:
    pptSld.Shapes.Paste.Select
    lngSlideKount = lngSlideKount + 1
' END OF CHANGED CODE
' ======================================================================
'
    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    '
    'Activate PowerPoint application
    pptApp.ActiveWindow.ViewType = ppViewNormal
    pptApp.Visible = True
    pptApp.Activate
    If lngSlideKount > 0 Then
        If lngSlideKount = 1 Then
            MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
        Else
            MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
        End If
    End If
    GoTo Exit_Para
Error_Para:
    MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & _
        Err.Description & vbCrLf & vbCrLf & _
        "copying charts to PowerPoint", vbOKOnly + vbCritical, "Error"
Exit_Para:
    On Error Resume Next
    Set ws = Nothing
    Set objChart = Nothing
    Set objChartObject = Nothing
    Set pptSld = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

 

[nmoiseff]

Derek,

Thank you very much for the quick response. This code helps but it does not loop through each worksheet in the workbook, nor does it add a slide for each worksheet. I have modified your code some so that it adds a new powerpoint slide, but it still does not copy content from each worksheet and paste it to the slide. Instead it copies a cell range from the active worksheet and pastes that same content to a new slide.

For example, I have 18 worksheets in my workbook. Right now the code copies cell range I1:Y35 from the activeworksheet 18 times and puts it on 18 different powerpoint slides. Ideally I would like cell range I1:Y35 from worksheet1 -> PowerPoint Slide #1, cell range I1:Y35 from worksheet2 -> PowerPoint Slide #2, cell range I1:Y35 from worksheet3 -> PowerPoint Slide #3, etc.

How would I loop it so that it performs the copy function on each worksheet? I thought it was the 'For Each ws in Activeworkbook.worksheets' command, but this doesnt seem to do the trick. Your code (that I modified) is below.

Again, thank you very much for the help.


Sub CopyChartsToPowerPoint3()
'
'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long
'
'Powerpoint Application objects declaration
' You need to add a reference (Tools | References) to the Microsoft PowerPoint nn.nn Object Library
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
'
On Error GoTo Error_Para
'
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
'
pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation
'
pptApp.ActiveWindow.ViewType = ppViewSlide
'
lngSlideKount = 0
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
' ======================================================================
' Changed code in this Message Board post:
' This code needs to be tidied
' e.g. Dim wb as Workbook
' Set wb = ThisWorkbook
' Set ws = wb.Worksheets("MySheet")
' etc.
' ======================================================================
' select sheet containing data to be copied to PowerPoint:
For Each ws In ActiveWorkbook.Worksheets
' select cells to be copied to PowerPoint:
Range("I1:Y35").Select
' copy cells:
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' past to PowerPoint:
pptSld.Shapes.Paste.Select
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
Next ws
' END OF CHANGED CODE
' ======================================================================
'
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'
'Activate PowerPoint application
pptApp.ActiveWindow.ViewType = ppViewNormal
pptApp.Visible = True
pptApp.Activate
If lngSlideKount > 0 Then
If lngSlideKount = 1 Then
MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
Else
MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
End If
End If
GoTo Exit_Para
Error_Para:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & _
Err.Description & vbCrLf & vbCrLf & _
"copying charts to PowerPoint", vbOKOnly + vbCritical, "Error"
Exit_Para:
On Error Resume Next
Set ws = Nothing
Set objChart = Nothing
Set objChartObject = Nothing
Set pptSld = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub

 

[Derek Brown]

I just gave a simple example that you could build upon - it is one thing copying ALL charts but when it comes to worksheets, it is very likely that you would not want all of them.
Try the following changes to the code:

    lngSlideKount = 0
For Each ws In ActiveWorkbook.Worksheets
    'ppLayoutBlank = 12
    Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
    pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
' ======================================================================
' Changed code in this Message Board post:
' This code needs to be tidied
' e.g. Dim wb as Workbook
' Set wb = ThisWorkbook
' Set ws = wb.Worksheets("MySheet")
' etc.
' ======================================================================
' select sheet containing data to be copied to PowerPoint:
    'Sheets("MySheet").Select
    ws.Select
' select cells to be copied to PowerPoint:
    'Range("A1:I24").Select
    ws.Range("I1:Y35").Select
' copy cells:
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' past to PowerPoint:
    pptSld.Shapes.Paste.Select
    lngSlideKount = lngSlideKount + 1
' END OF CHANGED CODE
' ======================================================================

    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'
Next ws
'
'Activate PowerPoint application

If you later find that you do not want ALL worksheets then the solution is to list those that you do want, in a table and give the column a (range) name.Then change the code to get the names within the loop and select each of those sheets in turn.

 

[nmoiseff]

I modified the code that you suggested but I receive an error when I attempt to run the Macro; Error 1004 Method 'Select' of object '_Worksheet' failed.

The code that I copied in is the following;

lngSlideKount = 0
For Each ws In ActiveWorkbook.Worksheets
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
' ======================================================================
' Changed code in this Message Board post:
' This code needs to be tidied
' e.g. Dim wb as Workbook
' Set wb = ThisWorkbook
' Set ws = wb.Worksheets("MySheet")
' etc.
' ======================================================================
' select sheet containing data to be copied to PowerPoint:
'Sheets("MySheet").Select
ws.Select
' select cells to be copied to PowerPoint:
'Range("A1:I24").Select
ws.Range("I1:Y35").Select
' copy cells:
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' past to PowerPoint:
pptSld.Shapes.Paste.Select
lngSlideKount = lngSlideKount + 1
' END OF CHANGED CODE
' ======================================================================

pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'
Next ws

Is it the "ws.Select" command that is throwing this error? I tried to modify it to ActiveWorkbook.ws.select but this does not work either. Any ideas?