Embed an Excel Chart into PowerPoint - VBA

Hi,
I am trying to copy a ChartObject created in a workbook sheet and paste it into a powerpoint 2010 slide, such that it becomes a standalone Excel Chart with data (embedded).

When i do it manually i.e :

1. Copy ChartObject present in WorkSheet
2. Goto Powerpoint Slide
3. Click PasteSpecial & select "Use Destination Theme & Embed Workbook (H)".
4. Right-click the ChartObject in Powerpoint & click "Edit Data".

Then i get a new standalone workbook with Title "Chart in Microsoft Excel", that shows the Chart as well as data. I have not been able to replicate this scenario where i get a new standalone workbook with Title "Chart in Microsoft Excel" using Excel VBA. Can someone help?

Assuming there is a simple column chart on the sheet, here is the code:

PHP Code:

---

Option Explicit
Sub doit()
Dim Temp As Workbook
Dim Rng As Range
Dim ChtObj As ChartObject

With ThisWorkbook.Sheets(1)
    Set ChtObj = .ChartObjects(1)
    With ChtObj
        .Copy
    End With

    Dim ppapp As Object
    Dim pppres As Object
    Dim ppslide As Object

    On Error Resume Next
    Set ppapp = GetObject(, "Powerpoint.Application")

    If ppapp Is Nothing Then
        Set ppapp = CreateObject("Powerpoint.Application")
    End If
    On Error GoTo 0

    Set pppres = ppapp.presentations.Add
    Set ppslide = pppres.Slides.Add(1, 12)

    With ppapp
        .Activate
        .Visible = msoTrue
        .ActiveWindow.viewtype = 1
    End With

    ChtObj.Copy
    ppapp.ActiveWindow.View.Paste

End With
End Sub 


---

i have tried :

PHP Code:

---

ppslide.Shapes.PasteSpecial(11, 0, , , , 0) '11 = ppPasteShape 


---

OR

PHP Code:

---

ppslide.Shapes.PasteSpecial 10, 0, , , , 0 '10 = ppPasteOLEObject 


---

OR

PHP Code:

---

ppapp.ActiveWindow.View.PasteSpecial 10, 0, , , , 0 


---

but it did not help!

is there anyone who can help me with my issue?

Hi,

Try

In a standard module

Code:

---

Option Explicit

Public wbkNew              As Workbook
Public WbkName              As String

Sub GetChartData(ByRef Chart_Object As ChartObject)

    Dim chtChart            As Chart
    Dim pntPoint            As Point
    Dim lngLoop            As Long
    Dim lngLoopSrs          As Long
    Dim lngSrsCount        As Long
    Dim lngPlotBy          As Long
    Dim lngChartType        As Long
    Dim lngSU              As Long
    Dim lngSecSrsCnt        As Long
    Dim wbkActive          As Workbook
    Dim wksNew              As Worksheet
    Dim varArrYVals()      As String
    Dim strNumFormatHeader  As String
    Dim strNumFormatData    As String
    Dim strNumFormatDataSec As String
    Dim strFmla            As String
    Dim strShtName          As String
    Dim strRange            As String
    Dim strListSep          As String
    Dim strAcell            As String
    Dim blnHasLabel        As Boolean
    Dim blnFlag            As Boolean
    Dim blnSizeStored      As Boolean
    Dim lngArrSecSrs()      As Long
    Dim varArrOutput()      As Variant
    Dim varXVal            As Variant
    Dim varYVal            As Variant
    Dim varVal              As Variant
    Dim varSpltFmla        As Variant
    Dim varSpltRange        As Variant
   
    With Application
        lngSU = .ScreenUpdating
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wbkActive = ThisWorkbook
    strAcell = ActiveCell.Address
   
    Set chtChart = Chart_Object.Chart
    lngPlotBy = chtChart.PlotBy
    lngSrsCount = chtChart.SeriesCollection.Count

    lngChartType = CLng(chtChart.ChartType)
   
    Select Case lngChartType

        Case -4111, 51, 52, 57, 58, 65, 93, 94  'Line,Column,Bar
       
            ReDim varArrOutput(1 To lngSrsCount + 1)
            ReDim varArrYVals(1 To lngSrsCount + 1)

            varXVal = chtChart.SeriesCollection(1).XValues
            varArrOutput(1) = varXVal
            varArrYVals(1) = vbNullString
           
            On Error Resume Next
            varYVal = chtChart.Axes(1, 1).CategoryNames
            strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
            If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
            strNumFormatData = chtChart.Axes(2, xlPrimary).TickLabels.NumberFormat
            strNumFormatDataSec = chtChart.Axes(2, xlSecondary).TickLabels.NumberFormat
            On Error GoTo 0
           
            If strNumFormatDataSec = vbNullString Then blnFlag = True
           
            For lngLoopSrs = 1 To lngSrsCount
                varVal = chtChart.SeriesCollection(lngLoopSrs).Values
                If Not blnFlag Then
                    If chtChart.SeriesCollection(lngLoopSrs).AxisGroup = 2 Then
                        lngSecSrsCnt = lngSecSrsCnt + 1
                        ReDim Preserve lngArrSecSrs(1 To lngSecSrsCnt)
                        lngArrSecSrs(lngSecSrsCnt) = lngLoopSrs
                    End If
                End If
                varArrOutput(lngLoopSrs + 1) = varVal
                varArrYVals(lngLoopSrs + 1) = chtChart.SeriesCollection(lngLoopSrs).Name
            Next
           
        Case -4102, 5, 69, 70 'Pie
       
            ReDim varArrOutput(1 To lngSrsCount + 1)
            ReDim varArrYVals(1 To lngSrsCount + 1)
           
            varXVal = chtChart.SeriesCollection(1).XValues
            varArrOutput(1) = varXVal
            varArrYVals(1) = vbNullString
           
            On Error Resume Next
           
            Set pntPoint = chtChart.SeriesCollection(1).Points(1)
            blnHasLabel = pntPoint.HasDataLabel
           
            varYVal = chtChart.Axes(1, 1).CategoryNames
           
            strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
            If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
            If Not blnHasLabel Then
                pntPoint.HasDataLabel = True
            End If
            strNumFormatData = pntPoint.DataLabel.NumberFormat
            pntPoint.HasDataLabel = blnHasLabel
            varArrYVals(2) = chtChart.SeriesCollection(1).Name
            varVal = chtChart.SeriesCollection(1).Values
            varArrOutput(2) = varVal
            On Error GoTo 0
       
        Case 87 'Bubble
           
            strListSep = Application.International(5)
            ReDim varArrOutput(1 To lngSrsCount, 1 To 4)
           
            strShtName = Replace(chtChart.Parent.Parent.Name, "'", "''")
            Application.Goto wbkActive.Worksheets(CStr(strShtName)).Range(CStr(strAcell))
            For lngLoopSrs = 1 To lngSrsCount
                strFmla = chtChart.SeriesCollection(lngLoopSrs).Formula
                strFmla = Mid$(strFmla, InStr(1, strFmla, "(") + 1)
                strFmla = Replace(Replace(Replace(strFmla, strShtName, ""), "!", ""), ")", "")
                varSpltFmla = Split(strFmla, strListSep)
                strRange = vbNullString
                For lngLoop = 0 To UBound(varSpltFmla)
                    If varSpltFmla(lngLoop) Like "$*$#*" Or varSpltFmla(lngLoop) Like "$*$#*:$*$#*" Then
                        strRange = strRange & strListSep & varSpltFmla(lngLoop)
                    ElseIf varSpltFmla(lngLoop) Like "{#*}" Then
                        varArrOutput(lngLoopSrs, 4) = CSng(Replace(Replace(varSpltFmla(lngLoop), "{", ""), "}", ""))
                        blnSizeStored = True
                    End If
                Next
                If Len(strRange) > Len(strListSep) Then
                    strRange = Mid$(strRange, Len(strListSep) + 1)
                    varSpltRange = Split(strRange, strListSep)
                    varArrOutput(lngLoopSrs, 1) = Evaluate("'" & strShtName & "'!" & varSpltRange(0))
                    varArrOutput(lngLoopSrs, 2) = Evaluate("'" & strShtName & "'!" & varSpltRange(1))
                    varArrOutput(lngLoopSrs, 3) = Evaluate("'" & strShtName & "'!" & varSpltRange(2))
                    If Not blnSizeStored Then
                        varArrOutput(lngLoopSrs, 4) = Evaluate("'" & strShtName & "'!" & varSpltRange(3))
                    End If
                End If
                blnSizeStored = False
            Next
           
            On Error Resume Next
           
            Set pntPoint = chtChart.SeriesCollection(1).Points(1)
            blnHasLabel = pntPoint.HasDataLabel
           
            varYVal = chtChart.Axes(1, 1).CategoryNames
           
            strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
            If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
           
            If Not blnHasLabel Then
                pntPoint.HasDataLabel = True
            End If
           
            strNumFormatData = pntPoint.DataLabel.NumberFormat
            pntPoint.HasDataLabel = blnHasLabel
            On Error GoTo 0
           
        Case Else
            GoTo Xit
    End Select
   
    Set wbkNew = Workbooks.Add(-4167)
    Set wksNew = wbkNew.Worksheets(1)

    If lngPlotBy = 1 Then
       
        For lngLoop = 1 To UBound(varArrOutput)
            wksNew.Cells(lngLoop, 1) = varArrYVals(lngLoop)
            wksNew.Cells(lngLoop, 2).Resize(, UBound(varArrOutput(lngLoop), 1)) = varArrOutput(lngLoop)
        Next
        wksNew.Cells(2, 2).Resize(UBound(varArrOutput), UBound(varArrOutput(1), 1)).NumberFormat = strNumFormatData
        On Error Resume Next
        wksNew.Cells(1, 2).Resize(, UBound(varYVal)).NumberFormat = "@"
        wksNew.Cells(1, 2).Resize(, UBound(varYVal)) = varYVal
        If Err.Number <> 0 Then
            wksNew.Cells(1, 2).Resize(, UBound(varArrOutput(1), 1)).NumberFormat = "@"
            wksNew.Cells(1, 2).Resize(, UBound(varArrOutput(1), 1)) = varYVal
            Err.Clear
        End If
        If Not blnFlag Then
            For lngLoop = 1 To lngSecSrsCnt
                wksNew.Cells(1 + lngArrSecSrs(lngLoop), 2).Resize(, UBound(varArrOutput(lngLoop), 1)).NumberFormat = strNumFormatDataSec
            Next
        End If
       
    ElseIf lngPlotBy = 0 Then
        Select Case lngChartType
            Case 87
                With wksNew.Range("a2")
                    .Resize(UBound(varArrOutput, 1), UBound(varArrOutput, 2)) = varArrOutput
                    .Offset(, 1).Resize(UBound(varArrOutput, 1), UBound(varArrOutput, 2) - 1).NumberFormat = strNumFormatData
                End With
            Case Else
                GoTo 2
        End Select
    ElseIf lngPlotBy = 2 Then
2:
        On Error Resume Next
        For lngLoop = 1 To UBound(varArrOutput)
            wksNew.Cells(1, lngLoop) = varArrYVals(lngLoop)
            wksNew.Cells(2, lngLoop).Resize(UBound(varArrOutput(lngLoop), 1)) = Application.Transpose(varArrOutput(lngLoop))
        Next
        Err.Clear
        wksNew.Cells(2, 1).Resize(UBound(varYVal)).NumberFormat = "@"
        If Err.Number <> 0 Then
            wksNew.Cells(2, 1).Resize(UBound(varArrOutput(1), 1)).NumberFormat = "@"
            Err.Clear
        End If
        wksNew.Cells(2, 1).Resize(UBound(varYVal)) = Application.Transpose(varYVal)
        wksNew.Cells(2, 2).Resize(UBound(varArrOutput(1), 1), UBound(varArrOutput)).NumberFormat = strNumFormatData
        If Not blnFlag Then
            For lngLoop = 1 To lngSecSrsCnt
                wksNew.Cells(2, 1 + lngArrSecSrs(lngLoop)).Resize(UBound(varArrOutput(1), 1), UBound(varArrOutput)).NumberFormat = strNumFormatDataSec
            Next
        End If
    End If
    wksNew.UsedRange.Columns.AutoFit
Xit:
    If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
   
    With Application
        .ScreenUpdating = lngSU
        .ScreenUpdating = True
    End With
End Sub

---

Insert another module and paste the following

Code:

---

Option Explicit

Public Enum PasteFormat
    xl_Link = 0
    xl_HTML = 1
    xl_Bitmap = 2
    xl_Embed = 3
End Enum

Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
                                    ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)
   
    '  Modified version of code originally posted here:
    '      http://www.vbaexpress.com/kb/getarticle.php?kb_id=370
   
    '  Modified by    : Admin @ ExcelFox.com
    '  Used Late binding so that no issues when users have multiple Excel version
   
    Dim PasteRange      As Boolean
    Dim objChart        As ChartObject
    Dim lngSU          As Long
    Dim strFName        As String
   
    Select Case TypeName(PasteObject)
        Case "Range"
            If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
            PasteRange = True
        Case "Chart": Set objChart = PasteObject.Parent
        Case "ChartObject": Set objChart = PasteObject
        Case Else
            MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
            Exit Sub
    End Select
   
    With Application
        lngSU = .ScreenUpdating
        .ScreenUpdating = 0
    End With
   
    ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber
   
    On Error GoTo -1: On Error GoTo 0
    DoEvents
   
    If PasteRange Then
        If Paste_Type = xl_Bitmap Then
            '//Paste Range as Picture
            PasteObject.CopyPicture Appearance:=1, Format:=-4147
            ppSlide.Shapes.Paste.Select
        ElseIf Paste_Type = xl_HTML Then
            '//Paste Range as HTML
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(8, link:=1).Select  'ppPasteHTML
        ElseIf Paste_Type = xl_Link Then
            '//Paste Range as Linked
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(0, link:=1).Select  'ppPasteDefault
        End If
    Else
        If Paste_Type = xl_Link Then
            '//Copy & Paste Chart Linked
            objChart.Chart.ChartArea.Copy
            ppSlide.Shapes.PasteSpecial(link:=True).Select
        ElseIf Paste_Type = xl_Embed Then
            ppSlide.Shapes.AddOLEObject Left:=100, Top:=50, _
                    Width:=objChart.Width, Height:=objChart.Height, _
                    Filename:=WbkName
            ppSlide.Shapes(1).Select
            Kill WbkName
        ElseIf Paste_Type = xl_Link Then
            '//Copy & Paste Chart Not Linked
            objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
            ppSlide.Shapes.Paste.Select
        End If
    End If
   
    '//Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Xit:
    With Application
        .CutCopyMode = False
        .ScreenUpdating = lngSU
    End With
   
    AppActivate ("Microsoft Excel")
   
End Sub

---

and call the procedure like

Code:

---

Sub kTest()
   
    Dim ppApp      As Object
    Dim ppSlide    As Object
    Dim blnEmbed    As Boolean
    Dim objChart    As ChartObject
   
    blnEmbed = True
   
    On Error Resume Next
    Set ppApp = GetObject(, "Powerpoint.Application")
    On Error GoTo 0
   
    If ppApp Is Nothing Then
        Set ppApp = CreateObject("Powerpoint.Application")
        ppApp.Visible = True
        ppApp.presentations.Add
    End If
   
   
    If ppApp.ActivePresentation.Slides.Count = 0 Then
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
    Else
        ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
        Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
    End If
   
    Set objChart = ThisWorkbook.Worksheets(1).ChartObjects(1)
   
    If blnEmbed Then
        Set wbkNew = Nothing
        WbkName = vbNullString
        GetChartData objChart
        If Not wbkNew Is Nothing Then
            wbkNew.Worksheets.Add wbkNew.Worksheets(1)
            objChart.Copy
            wbkNew.Worksheets(1).Paste
            wbkNew.Worksheets(1).ChartObjects(1).Chart.SetSourceData wbkNew.Worksheets(2).Range("a1").CurrentRegion
            wbkNew.SaveAs ThisWorkbook.Path & "\chart_temp.xlsx", 51
            WbkName = wbkNew.FullName
            wbkNew.Close
            Copy_Paste_to_PowerPoint ppApp, ppSlide, objChart.Parent, objChart.Chart, xl_Embed
        Else
            GoTo Xit
        End If
    Else
        Copy_Paste_to_PowerPoint ppApp, ppSlide, objChart.Parent, objChart.Chart, xl_Bitmap
    End If
   
Xit:
End Sub

---

This will give you a start. Adjust the codes wherever necessary.

Thanks Admin.
I see you are creating a temp workbook to embed the chart. However, it does not give the same effect as PasteSpecial - "Use Destination Theme & Embed Workbook (H)". I am using Excel 2010.
,
When i right-click the chartobject, i get 3 options:
1] Open
2] Edit
3] Convert.

But i do not get 'Edit Data' option, which i would normally get when i PasteSpecial into a new Presentation using option "Use Destination Theme & Embed Workbook (H)".

When i select 'Edit' option, i get an embedded workbook in the chart itself and not as a standalone excel window.

Can you try copying the chart and pasting it in a new powerpoint presentation and see the difference? See attached files for example.
In ppt deck, slide 1 is from your code, slide 2 is manually pastespecial by me using option "Use Destination Theme & Embed Workbook (H)". You will notice the difference. When you right-click the 2nd slide chart, it opens a new workbook in a new window with title showing "Chart in Microsoft Excel". I am unable to replicate this option.

Hope this is clear.