I asked this last week and no-one replied therefore I will try again.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o
></o>
I found the following script on this site for copying charts from excel to powerpoint, it copies charts from each excel tab to a new slide in powerpoint.<o></o>
Can anyone help with a similar script that if a sheet has 2 charts or 3 etc... on one sheet tab then it would copy all the charts on that tab to the same powerpoint slide.<o></o>
<o></o>
Just to clarify.
It would copy multiple charts on any given tab to the same slide so sheet1 charts would go to slide 1, charts on sheet2 would go to slide 2 etc... but it would still copy single charts on the other tabs to their own slide. <o></o>
fficeffice" /><o></o>I found the following script on this site for copying charts from excel to powerpoint, it copies charts from each excel tab to a new slide in powerpoint.<o
></o>Can anyone help with a similar script that if a sheet has 2 charts or 3 etc... on one sheet tab then it would copy all the charts on that tab to the same powerpoint slide.<o
></o><o
></o>Just to clarify.
It would copy multiple charts on any given tab to the same slide so sheet1 charts would go to slide 1, charts on sheet2 would go to slide 2 etc... but it would still copy single charts on the other tabs to their own slide. <o
></o>
Code:
Sub Chart2PPT() <o:p></o:p>
<o:p></o:p>
Dim objPPT As Object <o:p></o:p>Dim shtTemp As Object <o:p></o:p>
Dim objShape As Shape <o:p></o:p>Dim objGShape As Shape <o:p></o:p>Dim intSlide As Integer <o:p></o:p>
Dim blnCopy As Boolean <o:p></o:p>
Dim blnExistingPPTApp As Boolean <o:p></o:p>
<o:p></o:p>
On Error Resume Next <o:p></o:p>
Set objPPT = GetObject(, "PowerPoint.Application") <o:p></o:p>
Err.Clear: On Error Goto 0: On Error Goto -1 <o:p></o:p>
<o:p></o:p>
If objPPT Is Nothing Then <o:p></o:p>
Set objPPT = CreateObject("Powerpoint.application") <o:p></o:p>
objPPT.Presentations.Add <o:p></o:p>
Else <o:p></o:p>
blnExistingPPTApp = True <o:p></o:p>
End If <o:p></o:p>
objPPT.Visible = True <o:p></o:p>
objPPT.ActiveWindow.ViewType = 1 'ppViewSlide<o:p></o:p>
<o:p></o:p>
For Each shtTemp In ThisWorkbook.Sheets <o:p></o:p>
blnCopy = False <o:p></o:p>
If shtTemp.Type = xlWorksheet Then <o:p></o:p>
For Each objShape In shtTemp.Shapes 'chtTemp In shtTemp.ChartObjects<o:p></o:p>
blnCopy = False <o:p></o:p>
If objShape.Type = msoGroup Then <o:p></o:p>
'If ANY Item In Group Is A Chart<o:p></o:p>
For Each objGShape In objShape.GroupItems <o:p></o:p>
If objGShape.Type = msoChart Then <o:p></o:p>
blnCopy = True <o:p></o:p>
Exit For <o:p></o:p>
End If <o:p></o:p>
Next <o:p></o:p>
End If <o:p></o:p>
If objShape.Type = msoChart Then blnCopy = True <o:p></o:p>
<o:p></o:p>
If blnCopy Then <o:p></o:p>
intSlide = intSlide + 1 <o:p></o:p>
objShape.CopyPicture <o:p></o:p>
'New Slide For Each Chart<o:p></o:p>
If blnExistingPPTApp Then <o:p></o:p>
objPPT.ActiveWindow.View.GotoSlide Index:=intSlide <o:p></o:p>
Else <o:p></o:p>
objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.slides.Add(Index:=objPPT.ActivePresentation.slides.Count + 1, Layout:=12).SlideIndex <o:p></o:p>
End If <o:p></o:p>
objPPT.ActiveWindow.View.Paste <o:p></o:p>
End If <o:p></o:p>
Next <o:p></o:p>
If Not blnCopy Then <o:p></o:p>
'Copy Used Range<o:p></o:p>
intSlide = intSlide + 1 <o:p></o:p>
shtTemp.UsedRange.CopyPicture <o:p></o:p>
'New Slide For Each Chart<o:p></o:p>
If blnExistingPPTApp Then <o:p></o:p>
objPPT.ActiveWindow.View.GotoSlide Index:=intSlide <o:p></o:p>
Else <o:p></o:p>
objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.slides.Add(Index:=objPPT.ActivePresentation.slides.Count + 1, Layout:=12).SlideIndex <o:p></o:p>
End If <o:p></o:p>
objPPT.ActiveWindow.View.Paste <o:p></o:p>
With objPPT.ActivePresentation <o:p></o:p>
If .slides(intSlide).Shapes(1).Height / .PageSetup.SlideHeight > .slides(intSlide).Shapes(1).Width / .PageSetup.SlideWidth Then <o:p></o:p>
.slides(intSlide).Shapes(1).Height = .PageSetup.SlideHeight * 0.95 <o:p></o:p>
Else <o:p></o:p>
.slides(intSlide).Shapes(1).Width = .PageSetup.SlideWidth * 0.95 <o:p></o:p>
End If <o:p></o:p>
With .slides(intSlide).Shapes(1) <o:p></o:p>
.Left = (objPPT.ActivePresentation.PageSetup.SlideWidth / 2) - (.Width / 2) <o:p></o:p>
.Top = (objPPT.ActivePresentation.PageSetup.SlideHeight / 2) - (.Height / 2) <o:p></o:p>
End With <o:p></o:p>
End With <o:p></o:p>
End If <o:p></o:p>
Else <o:p></o:p>
intSlide = intSlide + 1 <o:p></o:p>
shtTemp.CopyPicture <o:p></o:p>
'New Slide For Each Chart<o:p></o:p>
If blnExistingPPTApp Then <o:p></o:p>
objPPT.ActiveWindow.View.GotoSlide Index:=intSlide <o:p></o:p>
Else <o:p></o:p>
objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.slides.Add(Index:=objPPT.ActivePresentation.slides.Count + 1, Layout:=12).SlideIndex <o:p></o:p>
End If <o:p></o:p>
objPPT.ActiveWindow.View.Paste <o:p></o:p>
With objPPT.ActivePresentation <o:p></o:p>
If .slides(intSlide).Shapes(1).Height / .PageSetup.SlideHeight > .slides(intSlide).Shapes(1).Width / .PageSetup.SlideWidth Then <o:p></o:p>
.slides(intSlide).Shapes(1).Height = .PageSetup.SlideHeight * 0.95 <o:p></o:p>
Else<o:p></o:p>
.slides(intSlide).Shapes(1).Width = .PageSetup.SlideWidth * 0.95 <o:p></o:p>
End If <o:p></o:p>
With .slides(intSlide).Shapes(1) <o:p></o:p>
.Left = (objPPT.ActivePresentation.PageSetup.SlideWidth / 2) - (.Width / 2) <o:p></o:p>
.Top = (objPPT.ActivePresentation.PageSetup.SlideHeight / 2) - (.Height / 2) <o:p></o:p>
End With <o:p></o:p>
End With <o:p></o:p>
End If <o:p></o:p>
Next <o:p></o:p>
<o:p></o:p>
Set objPPT = Nothing <o:p></o:p>
Set shtTemp = Nothing <o:p></o:p>
Set objShape = Nothing <o:p></o:p>
Set objGShape = Nothing <o:p></o:p>
intSlide = Empty <o:p></o:p>
blnCopy = False <o:p></o:p>
blnExistingPPTApp = False <o:p></o:p>
<o:p></o:p>
End Sub<o:p></o:p>
