Hi Raghu,
Select the charts and run the below macro.
Please let me know if there are any problems.
Sub CopyChartsIntoPowerPoint()
''' COPY SELECTED EXCEL CHARTS INTO POWERPOINT
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim pptApp As PowerPoint.Application
Dim iShapeIx As Integer, iShapeCt As Integer
Dim myShape As Shape, myChart As ChartObject
Dim bCopied As Boolean
Set pptApp = GetObject(, "PowerPoint.Application")
If ActiveChart Is Nothing Then
''' SELECTION IS NOT A SINGLE CHART
On Error Resume Next
iShapeCt = Selection.ShapeRange.Count
If Err Then
MsgBox "Select charts and try again", vbCritical, "Nothing Selected"
Exit Sub
End If
On Error GoTo 0
For Each myShape In Selection.ShapeRange
''' IS SHAPE A CHART?
On Error Resume Next
Set myChart = ActiveSheet.ChartObjects(myShape.Name)
If Not Err Then
bCopied = CopyChartToPowerPoint(pptApp, myChart)
End If
On Error GoTo 0
Next
Else
''' CHART ELEMENT OR SINGLE CHART IS SELECTED
Set myChart = ActiveChart.Parent
bCopied = CopyChartToPowerPoint(pptApp, myChart)
End If
Dim myPptShape As PowerPoint.Shape
Dim myScale As Single
Dim iShapesCt As Integer
''' BAIL OUT IF NO PICTURES ON SLIDE
On Error Resume Next
iShapesCt = pptApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If Err Then
MsgBox "There are no shapes on the active slide", vbCritical, "No
Shapes"
Exit Sub
End If
On Error GoTo 0
''' ASK USER FOR SCALING FACTOR
myScale = InputBox(Prompt:="Enter a scaling factor for the shapes
(percent)", _
Title:="Enter Scaling Percentage") / 100
''' LOOP THROUGH SHAPES AND RESCALE "PICTURES"
For Each myPptShape In pptApp.ActiveWindow.Selection.SlideRange.Shapes
If myPptShape.Name Like "Picture*" Then
With myPptShape
.ScaleWidth myScale, msoTrue, msoScaleFromMiddle
.ScaleHeight myScale, msoTrue, msoScaleFromMiddle
End With
End If
Next
Set myChart = Nothing
Set myShape = Nothing
Set myPptShape = Nothing
Set pptApp = Nothing
End Sub
Sub CopyChartsIntoPowerPoint()
''' COPY SELECTED EXCEL CHARTS INTO POWERPOINT
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim pptApp As PowerPoint.Application
Dim iShapeIx As Integer, iShapeCt As Integer
Dim myShape As Shape, myChart As ChartObject
Dim bCopied As Boolean
Set pptApp = GetObject(, "PowerPoint.Application")
If ActiveChart Is Nothing Then
''' SELECTION IS NOT A SINGLE CHART
On Error Resume Next
iShapeCt = Selection.ShapeRange.Count
If Err Then
MsgBox "Select charts and try again", vbCritical, "Nothing Selected"
Exit Sub
End If
On Error GoTo 0
For Each myShape In Selection.ShapeRange
''' IS SHAPE A CHART?
On Error Resume Next
Set myChart = ActiveSheet.ChartObjects(myShape.Name)
If Not Err Then
bCopied = CopyChartToPowerPoint(pptApp, myChart)
End If
On Error GoTo 0
Next
Else
''' CHART ELEMENT OR SINGLE CHART IS SELECTED
Set myChart = ActiveChart.Parent
bCopied = CopyChartToPowerPoint(pptApp, myChart)
End If
Dim myPptShape As PowerPoint.Shape
Dim myScale As Single
Dim iShapesCt As Integer
''' BAIL OUT IF NO PICTURES ON SLIDE
On Error Resume Next
iShapesCt = pptApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If Err Then
MsgBox "There are no shapes on the active slide", vbCritical, "No
Shapes"
Exit Sub
End If
On Error GoTo 0
''' ASK USER FOR SCALING FACTOR
myScale = InputBox(Prompt:="Enter a scaling factor for the shapes
(percent)", _
Title:="Enter Scaling Percentage") / 100
''' LOOP THROUGH SHAPES AND RESCALE "PICTURES"
For Each myPptShape In pptApp.ActiveWindow.Selection.SlideRange.Shapes
If myPptShape.Name Like "Picture*" Then
With myPptShape
.ScaleWidth myScale, msoTrue, msoScaleFromMiddle
.ScaleHeight myScale, msoTrue, msoScaleFromMiddle
End With
End If
Next
Set myChart = Nothing
Set myShape = Nothing
Set myPptShape = Nothing
Set pptApp = Nothing
End Sub
On Thu, Apr 9, 2009 at 2:34 AM, <jamadagnira...@gmail.com> wrote:
>
> Hi All,
>
> Please find the attachment.
>
> My requirements is –
>
> Can anyone tell me how to pull the charts from the excel file to the
> PPT? I want two charts to be placed in ONE PPT. For example – Chart 1
> & Chart 2 should go to PPT Slide 1 and Chart 3 & Chart 4 should go PPT
> Slide 2 and likewise. I want it be placed centrally.
>
> I have to update lots of Charts to update in the PPT from excel file
> every month and its very annoying to copy and paste one by one and
> consumes lots of time. PLEASE HELP.
>
>
> Regards,
> Raghu J.
>
> >
>
--
Hari kumar
--~--~---------~--~----~------------~-------~--~----~
-------------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
-------------------------------------------------------------------------------------
-~----------~----~----~----~------~----~------~--~---
