Copy/Export/Transfer charts from Excel to power point with VBA cod

[Guest]

Hi I want to copy/export/transfer charts from Excel to powerpoint. I have a
workbook which contains 4 sheets with 2 charts in each sheet. I want each
chart to appear to a separate slide in power point. I want to do that with
VBA code. I already have some code put it doesnt works.
The ppt file opens ok but in the function gives an error "Object doesnt
support this property or method"

Sub openppt()

Dim pptapplication As Object
Dim pptopen As Object
Dim pptpath As String

pptpath = "C:\Test\THIS IS A TEST.ppt"

Set pptapplication = CreateObject("powerpoint.Application")
pptapplication.Visible = True
Set pptopen = pptapplication.Presentations.Open(Filename:=pptpath)

End Sub

Public Function Test()
Dim xl As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
'Dim i%

Set xl = New Excel.Application
Set wb = xl.Workbooks.Open("C:\Test\SEQS.xls")
Set ws = wb.Worksheets(1)

With ActiveWindow.Selection.SlideRange ****HERE IT GIVES THE ERROR ****
For i = 1 To 3
.Shapes("Rectangle 2").TextFrame.TextRange.Text = ws.Cells(i,
1).Value
.Shapes("Rectangle 3").TextFrame.TextRange.Text = ws.Cells(i,
2).Value
ActiveWindow.Presentation.PrintOut 1, 1
Next i
End With

Set ws = Nothing
wb.Close SaveChanges:=False
Set wb = Nothing
xl.Quit
Set xl = Nothing

End Function

 

[Guest]

The problem is that once you've opened your excel application it becomes the
active object and so the code is trying to apply this line:-

With ActiveWindow.Selection.SlideRange

to Excel and not Powerpoint

If you rewrite your function so it includes the openppt subroutine and
change the line above to read:-

With pptapplication.ActiveWindow.Selection.SlideRange

I think it will work

Revised code is below:-

Public Function Test()
Dim xl As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim pptapplication As Object
Dim pptopen As Object
Dim pptpath As String
'Dim i%

Set xl = New Excel.Application
Set wb = xl.Workbooks.Open("c:\Test\SEQS.xls")
Set ws = wb.Worksheets(1)

pptpath = "C:\Test\THIS IS A TEST.ppt"

Set pptapplication = CreateObject("powerpoint.Application")
pptapplication.Visible = True
Set pptopen = pptapplication.Presentations.Open(Filename:=pptpath)

With pptapplication.ActiveWindow.Selection.SlideRange
For i = 1 To 3
.Shapes("Rectangle 2").TextFrame.TextRange.Text = ws.Cells(i,
1).Value
.Shapes("Rectangle 3").TextFrame.TextRange.Text = ws.Cells(i,
2).Value
ActiveWindow.Presentation.PrintOut 1, 1
Next i
End With

Set ws = Nothing
wb.Close SaveChanges:=False
Set wb = Nothing
xl.Quit
Set xl = Nothing

End Function

HTH

Andy W