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.
Reply With Quote
Bookmarks