Как скопировать и вставить диаграммы из Excel в заполнители в PowerPoint?

Question

У меня есть 2 диаграммы на каждом листе в рабочей книге, и я хотел бы скопировать 2 в заполнители каждого слайда. Теперь код продолжает создавать новую PowerPoint вместо того, чтобы использовать шаблон, который я открыл. У меня есть следующий код.

Sub CopyPasteCharts()

MsgBox "Select the file you have generated.", vbInformation + vbOKOnly

Dim fNameAndPath As Variant, wb As Workbook
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")

If fNameAndPath = False Then Exit Sub

Set wb = Workbooks.Open(fNameAndPath)
wb.Activate

Dim ppt As PowerPoint.Application
Dim ppTPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptCL As PowerPoint.CustomLayout
Dim pptShp As PowerPoint.Shape

Dim chtt As Chart
Dim ws As Worksheet
Dim i As Long

'Optimise execution of code
Application.ScreenUpdating = False

'Get the PowerPoint Application object:
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = msoTrue
'Set ppTPres = ppt.Presentations.Add

'Get a Custom Layout:
For Each pptCL In ppTPres.SlideMaster.CustomLayouts
    If pptCL.Name = "Title and Content" Then Exit For
Next pptCL

'Copy ALL charts embedded in EACH WorkSheet:
For Each ws In ActiveWorkbook.Worksheets

    Set pptSld = ppTPres.Slides.AddSlide(ppTPres.Slides.Count + 1, pptCL)
    pptSld.Select

    For i = 1 To ws.ChartObjects.Count

        For Each pptShp In pptSld.Shapes.Placeholders
            If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
        Next pptShp

        Set chtt = ws.ChartObjects(i).Chart

        chtt.ChartArea.Copy

        ppt.Activate
        pptShp.Select
        ppt.Windows(1).View.Paste

    Next i
Next ws

'Optimise execution of code
Set chtt = Nothing
Set pptSld = Nothing
Application.ScreenUpdating = True

'Clear clipboard
Application.CutCopyMode = False
End Sub

вот так выглядят мои заполнители

[EDIT]

Я изменил код, но там , Нижний индекс выходит за пределы диапазона: ActiveWorkbook.Worksheets("Chart 1").ChartObjects(1).Activate.ChartArea.Copy

Новый код:

'Чтобы получить файл

fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")

If fNameAndPath = False Then Exit Sub

Set wb = Workbooks.Open(fNameAndPath)
wb.Activate

Dim obPptApp As PowerPoint.Application
Dim OpenPptDialogBox As Object
Dim MyChart As Chart
Dim MyShape As Object

Set obPptApp = CreateObject("PowerPoint.Application")
Set OpenPptDialogBox = obPptApp.FileDialog(msoFileDialogOpen)

'Open the target PPT using dialog box
If OpenPptDialogBox.Show = -1 Then
obPptApp.Presentations.Open (OpenPptDialogBox.SelectedItems(1))
End If

'Copy the chart from excel macro file

ActiveWorkbook.Worksheets("Chart 1").ChartObjects(1).Activate.ChartArea.Copy

'Paste the chart in  slide 1 of PPT
 Set MyShape = obPptApp.ActiveWindow.Presentation.Slides(1).Shapes.Paste