Есть ли способ скопировать и вставить несколько диаграмм, сгруппированных в Excel, в PowerPoint, используя VBA?

Question

Есть ли способ, с помощью которого я могу копировать и вставлять несколько диаграмм, сгруппированных в четыре, как показано ниже, от Excel до моих слайдов 28 PowerPoint и слайдов 29? Названия групп: группа 16 для левой группы, группа 17 для правой группы. Я попытался использовать Chrt.CopyPicture, но он копирует диаграммы на слайды отдельно, а не в группу, как один контур на 4 диаграммах, показанных в левой части рисунка ниже. Кстати, мой единственный код копирует только графики по отдельности в слайд 28.

Sub ExportChartsTopptSingleWorksheet()

    'Declare PowerPoint Variables
    Dim PPTApp As Object
    Dim PPTPres As Object
    Dim PPTShape As Object
    Dim mySlide, myslide2 As Object

    'Declare Excel Variables
    Dim Chrt As ChartObject


If PPTApp Is Nothing Then _
Set PPTApp = CreateObject(class:="PowerPoint.Application")

On Error GoTo 0
        PPTApp.Visible = True

    'Create new presentation in the PowerPoint application.
      Set PPTPres = PPTApp.Presentations.Open(Filename:="\\fab2crp-nas1\home22\kkang2\Profile\Desktop\myassignment3\mypresentationsample.pptx")

    Set mySlide = PPTPres.Slides.Add(28, 1) 

        'Loop through all the CHARTOBJECTS in the ACTIVESHEET.
        For Each Chrt In ActiveSheet.ChartObjects

            'Copy the Chart
            Chrt.CopyPicture  '<------ method copy fail error here                     

      'paste all the chart on to exisitng ppt slide 28
                mySlide.Shapes.Paste
           Next Chrt

    End Sub

В настоящее время графики копируются по отдельности в слайды ppt

Ожидается

Answer 1

Это сработало для меня.

Sub ExportChartsTopptSingleWorksheet()

    Const PER_ROW As Long = 2 'charts per row in PPT
    Const T_START As Long = 40 'start chart top
    Const L_START As Long = 40 'start chart left

    Dim PPTApp As Object
    Dim PPTPres As Object
    Dim PPTShape As Object
    Dim mySlide, myslide2 As Object, i As Long
    Dim Chrt As ChartObject, T As Long, L As Long


    If PPTApp Is Nothing Then _
    Set PPTApp = CreateObject(class:="PowerPoint.Application")
    PPTApp.Visible = True
    Set PPTPres = PPTApp.Presentations.Add()

    Set mySlide = PPTPres.Slides.Add(1, 1)

    i = 0
    For Each Chrt In ActiveSheet.ChartObjects
        Chrt.Chart.CopyPicture
        i = i + 1
        'work out the top/left values
        T = T_START + (Application.Floor((i - 1) / PER_ROW, 1)) * Chrt.Height
        L = L_START + ((i - 1) Mod PER_ROW) * Chrt.Width
        With mySlide.Shapes
            .Paste
            .Item(.Count).Top = T
            .Item(.Count).Left = L
        End With
    Next Chrt

End Sub