excel - 有没有办法使用 VBA 将在 excel 中分组的多个图表复制并粘贴到 powerpoint？

Question

有没有一种方法可以让我从 excel 中复制并粘贴到我现有的 powerpoint 幻灯片 28 和幻灯片 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幻灯片

预期的

标签： excelvbachartspowerpoint

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