Solved: How do I adapt this code to export Multiple Charts?

[Kacer26]

Hello!

So, I found this code on this VBAX site: (see below)

I need to modify the code so that it 'loops' through multiple worksheets (in the same workbook) and exports each chart(s) from each worksheet and pastes the chart into a new ppt slide).

Is this possible? I'm a VBA novice

-Any help would be greatly appreciated. Thanks in Advance.

[vba]

Sub Copy_Paste_to_PowerPoint()

'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide

'Original code sourced from Jon Peltier

Dim SheetName As String
Dim TestRange As Range
Dim TestSheet As Worksheet
Dim TestChart As ChartObject

Dim PasteChart As Boolean
Dim PasteChartLink As Boolean
Dim ChartNumber As Long

Dim PasteRange As Boolean
Dim RangePasteType As String
Dim RangeName As String
Dim AddSlidesToEnd As Boolean

'Parameters

'SheetName - name of sheet in Excel that contains the range or chart to copy

'PasteChart -If True then routine will copy and paste a chart
'PasteChartLink -If True then Routine will paste chart with Link; if = False then paste chart no link
'ChartNumber -Chart Object Number
'
'PasteRange - If True then Routine will copy and Paste a range
'RangePasteType - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values
'RangeName - Address or name of range to copy; "B3:G9" "MyRange"
'AddSlidesToEnd - If True then appednd slides to end of presentation and paste. If False then paste on current slide.

'use active sheet. This can be a direct sheet name
SheetName = Sheets("VOTD EXW").Name 'CHANGED

'Setting PasteRange to True means that Chart Option will not be used (DO NOT USE)
PasteRange = False
RangeName = "MyRange" 'CHANGED
RangePasteType = "HTML"
RangeLink = True

PasteChart = True
PasteChartLink = True
ChartNumber = 2

AddSlidesToEnd = True


'Error testing
On Error Resume Next
Set TestSheet = Sheets(SheetName)
Set TestRange = Sheets(SheetName).Range(RangeName)
Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber)
On Error GoTo 0

If TestSheet Is Nothing Then
MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If

If PasteRange And TestRange Is Nothing Then
MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If

If PasteRange = False And PasteChart And TestChart Is Nothing Then
MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical
Exit Sub
End If


'Look for existing instance
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Create new instance if no instance exists
If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
'Add a presentation if none exists
If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add

'Make the instance visible
PPApp.Visible = True

'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation
If PPApp.ActivePresentation.Slides.Count = 0 Then
Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
Else
If AddSlidesToEnd Then
'Appends slides to end of presentation and makes last slide active
PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
Set PPSlide = PPApp.ActivePresentation.Slides(PPApp.ActivePresentation.Slides.Count)
Else
'Sets current slide to active slide
Set PPSlide = PPApp.ActiveWindow.View.Slide
End If
End If

'Options for Copy & Paste Ranges and Charts
If PasteRange = True Then
'Options for Copy & Paste Ranges
If RangePasteType = "Picture" Then
'Paste Range as Picture
Worksheets(SheetName).Range(RangeName).Copy
PPSlide.Shapes.PasteSpecial(ppPasteDefault, link:=RangeLink).Select
Else
'Paste Range as HTML
Worksheets(SheetName).Range(RangeName).Copy
PPSlide.Shapes.PasteSpecial(ppPasteHTML, link:=RangeLink).Select
End If
Else
'Options for Copy and Paste Charts
Worksheets(SheetName).Activate
ActiveSheet.ChartObjects(ChartNumber).Select
If PasteChartLink = True Then
'Copy & Paste Chart Linked
ActiveChart.ChartArea.Copy
PPSlide.Shapes.PasteSpecial(link:=True).Select
Else
'Copy & Paste Chart Not Linked
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
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

AppActivate ("Microsoft PowerPoint")
Set PPSlide = Nothing
Set PPApp = Nothing

End Sub[/vba]

[Bob Phillips]

Can you post your workbook for us to test with?

[Kacer26]

Can you post your workbook for us to test with?

So, this ONLY a small portion of the file...I'm limited on what I'm able to upload...the whole file is close to 3MB.

Anyway, in the actual file I 19 worksheets they are labeled accordingly and they each contain 2 charts each and I need to copy each chart in each tab and paste each chart into a seperate powerpoint slide.

I'm thinking I can use the code that I found, but I may need to incorporate a For loop? (not sure)

Any help or suggestions would be greatly appreciated.

[Bob Phillips]

[vba]

Sub Copy_Paste_to_PowerPoint()

'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide

'Original code sourced from Jon Peltier

Dim SheetName As String
Dim TestRange As Range
Dim TestSheet As Worksheet
Dim TestChart As ChartObject
Dim ChartObj As ChartObject
Dim WS As Worksheet
Dim PPTShape As Object

Dim PasteChart As Boolean
Dim PasteChartLink As Boolean
Dim ChartNumber As Long

Dim PasteRange As Boolean
Dim RangePasteType As String
Dim RangeName As String
Dim AddSlidesToEnd As Boolean
Dim RangeLink As Boolean

'Parameters

'SheetName - name of sheet in Excel that contains the range or chart to copy

'PasteChart -If True then routine will copy and paste a chart
'PasteChartLink -If True then Routine will paste chart with Link; if = False then paste chart no link
'ChartNumber -Chart Object Number
'
'PasteRange - If True then Routine will copy and Paste a range
'RangePasteType - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values
'RangeName - Address or name of range to copy; "B3:G9" "MyRange"
'AddSlidesToEnd - If True then appednd slides to end of presentation and paste. If False then paste on current slide.

'use active sheet. This can be a direct sheet name
SheetName = Sheets("VOTD All").Name 'CHANGED

'Setting PasteRange to True means that Chart Option will not be used (DO NOT USE)
PasteRange = False
RangeName = "MyRange" 'CHANGED
RangePasteType = "HTML"
RangeLink = True

PasteChart = True
PasteChartLink = True
ChartNumber = 2

AddSlidesToEnd = True

'Error testing
On Error Resume Next
Set TestSheet = Sheets(SheetName)
Set TestRange = Sheets(SheetName).Range(RangeName)
Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber)
On Error GoTo 0

If TestSheet Is Nothing Then

MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If

If PasteRange And TestRange Is Nothing Then

MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If

If PasteRange = False And PasteChart And TestChart Is Nothing Then

MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical
Exit Sub
End If


'Look for existing instance
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Create new instance if no instance exists
If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
'Add a presentation if none exists
If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add

'Make the instance visible
PPApp.Visible = True

For Each WS In ActiveWorkbook.Worksheets

'Options for Copy & Paste Ranges and Charts
If PasteRange = True Then

'Options for Copy & Paste Ranges
If RangePasteType = "Picture" Then

'Paste Range as Picture
Worksheets(SheetName).Range(RangeName).Copy
PPSlide.Shapes.PasteSpecial(ppPasteDefault, link:=RangeLink).Select
Else

'Paste Range as HTML
Worksheets(SheetName).Range(RangeName).Copy
PPSlide.Shapes.PasteSpecial(ppPasteHTML, link:=RangeLink).Select
End If
Else

'Options for Copy and Paste Charts
For Each ChartObj In WS.ChartObjects

Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)

'ChartObj.Select
If PasteChartLink = True Then

'Copy & Paste Chart Linked
ChartObj.Chart.ChartArea.Copy
Set PPTShape = PPSlide.Shapes.PasteSpecial(link:=True)

'Center pasted object in the slide
PPTShape.Align msoAlignCenters, True
PPTShape.Align msoAlignMiddles, True
Else

'Copy & Paste Chart Not Linked
ChartObj.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select
End If
Next ChartObj
End If
Next WS


AppActivate ("Microsoft PowerPoint")
Set PPSlide = Nothing
Set PPApp = Nothing

End Sub
[/vba]

[Kacer26]

Hello There XLD,

So, it looks like the code is attempting to run BUT then I get an error for this line of code:

Set PPTShape = PPSlide.Shapes.PasteSpecial(link:=True)

And the Run-Time Error says:

Shapes (Unkown Member): Invlid request. The specified data type is unavailable

What does this mean?

NOTE: I do have my MS PPT Object Library activated - do I need to activate another object library to run the macro?

THANKKS

[Bob Phillips]

I don't know, it runs fine for me.

What Excel/PowerPoint versions do you use?

[Kacer26]

I'm using MS Office 2007.

I've googled for this and got these refs:

-Excel 2007 copy chart as bitmap cannot paste as ppBitMap into Powerpoint 2007

-PasteSpecial of Device Independent Bitmap with VBA in PP2007

But, I'm still not sure I understand how to fix the error, I'm going to continue searching.

It sounds like it may be in issue pasting to MS PPT 2007.....

[Bob Phillips]

I've just run it with Excel 2007 and PPT 2007, ran fine.

I am not sure what you were saying in that last post about those refs.

[Kacer26]

Hello XLD,

So I think I may have figured out the issue. So I went back and ran the code on the example sheet that I posted and the code ran fine as you stated.

HOWEVER, my actual worksheet contains the following tabs (in this order):
-HomeScreen
-VOTD All
-VOTD EXW
-VOTD Non-EXW

'HomeScreen is where I have 'Click' Buttons set up to run the actual macros for the users.

Is the fact that the chart objects don't actually start until VOTD All wksht the issue?

So, How can I add in a 'Start' marker to the code to begin with VOTD All and loop through until the end?

Thanks in Advance

[Bob Phillips]

See, it helps if you give us all of the facts

[vba]

Sub Copy_Paste_to_PowerPoint()

'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide

'Original code sourced from Jon Peltier

Dim SheetName As String
Dim TestRange As Range
Dim TestSheet As Worksheet
Dim TestChart As ChartObject
Dim ChartObj As ChartObject
Dim WS As Worksheet
Dim PPTShape As Object

Dim PasteChart As Boolean
Dim PasteChartLink As Boolean
Dim ChartNumber As Long

Dim PasteRange As Boolean
Dim RangePasteType As String
Dim RangeName As String
Dim AddSlidesToEnd As Boolean
Dim RangeLink As Boolean

'Parameters

'SheetName - name of sheet in Excel that contains the range or chart to copy

'PasteChart -If True then routine will copy and paste a chart
'PasteChartLink -If True then Routine will paste chart with Link; if = False then paste chart no link
'ChartNumber -Chart Object Number
'
'PasteRange - If True then Routine will copy and Paste a range
'RangePasteType - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values
'RangeName - Address or name of range to copy; "B3:G9" "MyRange"
'AddSlidesToEnd - If True then appednd slides to end of presentation and paste. If False then paste on current slide.

'Setting PasteRange to True means that Chart Option will not be used (DO NOT USE)
PasteRange = False
RangeName = "MyRange" 'CHANGED
RangePasteType = "HTML"
RangeLink = True

PasteChart = True
PasteChartLink = True
ChartNumber = 2

AddSlidesToEnd = True

'Look for existing instance
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Create new instance if no instance exists
If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
'Add a presentation if none exists
If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add

'Make the instance visible
PPApp.Visible = True

For Each WS In ActiveWorkbook.Worksheets

If WS.Name <> "Home Screen" Then

'Options for Copy & Paste Ranges and Charts
If PasteRange = True Then

'Options for Copy & Paste Ranges
If RangePasteType = "Picture" Then

'Paste Range as Picture
Worksheets(SheetName).Range(RangeName).Copy
PPSlide.Shapes.PasteSpecial(ppPasteDefault, link:=RangeLink).Select
Else

'Paste Range as HTML
Worksheets(SheetName).Range(RangeName).Copy
PPSlide.Shapes.PasteSpecial(ppPasteHTML, link:=RangeLink).Select
End If
Else

'Options for Copy and Paste Charts
For Each ChartObj In WS.ChartObjects

Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)

'ChartObj.Select
If PasteChartLink = True Then

'Copy & Paste Chart Linked
ChartObj.Chart.ChartArea.Copy
Set PPTShape = PPSlide.Shapes.PasteSpecial(link:=True)

'Center pasted object in the slide
PPTShape.Align msoAlignCenters, True
PPTShape.Align msoAlignMiddles, True
Else

'Copy & Paste Chart Not Linked
ChartObj.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select
End If
Next ChartObj
End If
End If
Next WS


AppActivate ("Microsoft PowerPoint")
Set PPSlide = Nothing
Set PPApp = Nothing

End Sub
[/vba]

[Kacer26]

YES SUCCESS! THANK YOU A MILLION TIMES! YOUR AWESOME!