Скопировать графики и таблицы Excel в Powerpoint

Question

Я пытаюсь создать диаграммы и таблицы в excel, а затем скопировать их в слайды в PowerPoint через макрос PowerPoint VBA. У меня есть диаграммы и таблицы, созданные, но у меня проблема с копированием и вставкой. Я не знаком с синтаксисом для этого. Любая помощь будет очень признательна, поскольку я новичок в PowerPoint VBA.

Sub GenerateVisual() 

    Dim dlgOpen As FileDialog 
    Dim folder As String 
    Dim excelApp As Object 
    Dim xlWorkBook As Object 
    Dim xlWorkBook2 As Object 
    Dim PPT As Presentation 
    Dim Name1 As String 
    Dim Name2 As String 

    Set PPT = ActivePresentation 

    Set excelApp = CreateObject("Excel.Application") 

    excelApp.Visible = True 


    Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls") 
    xlWorkBook.Sheets("MarketSegmentTotals").Activate 
    xlWorkBook.ActiveSheet.Shapes.AddChart.Select 
    xlWorkBook.ActiveChart.ChartType = xlColumnClustered 
    xlWorkBook.ActiveChart.SetSourceData Source:=xlWorkBook.ActiveSheet.Range("MarketSegmentTotals!$A$1:$F$2") 
    xlWorkBook.ActiveChart.Legend.Delete 
    xlWorkBook.ActiveChart.SetElement (msoElementChartTitleAboveChart) 
    xlWorkBook.ActiveChart.SetElement (msoElementDataLabelCenter) 
    xlWorkBook.ActiveChart.ChartTitle.Text = "DD Ready by Market Segment" 
    xlWorkBook.ActiveSheet.ListObjects.Add 

    xlWorkBook.ActiveSheet.ChartObjects(1).Select 'My attempt to copy them over but it doesnt work 
    PPT.ActiveWindow.View.Paste 

End Sub 

Answer 1

Эта подделка поможет вам в пути. Он нуждается в некоторых настройках, но это может скопировать на диапазон в PPT:

Public Sub RangeToPresentation(sheetName, NamedRange) 
    Dim CopyRng As Range 

    Set CopyRng = Sheets(sheetName).Range(NamedRange) 

    Dim ppApp As Object 
    Dim ppPres As Object 
    Dim PPSlide As Object 

    If Not TypeName(CopyRng) = "Range" Then 
     MsgBox "Please select a worksheet range and try again.", vbExclamation, _ 
      "No Range Selected" 
    Else 

     Set ppApp = GetObject(, "Powerpoint.Application") 

    Set ppPres = ppApp.ActivePresentation 
    ppApp.ActiveWindow.ViewType = ppViewNormal 

     Dim longSlideCount As Long 

     ' Determine how many slides are in the presentation. 
     longSlideCount = ppPres.Slides.Count 

     With ppPres 

     ' Insert a slide at the end of the presentation 
     Set PPSlide = ppPres.Slides.Add(longSlideCount + 1, ppLayoutBlank) 

     End With 

    ' Select the last (blank slide) 
    longSlideCount = ppPres.Slides.Count 
    ppPres.Slides(longSlideCount).Select 

    Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex) 

    CopyRng.CopyPicture Appearance:=xlScreen, _ 
     Format:=xlBitmap 

    ' Paste the range 
    PPSlide.Shapes.Paste.Select 

    'Set the image to lock the aspect ratio 
    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue 

    'Set the image size slightly smaller than width of the PowerPoint Slide 
    ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10 
    ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10 

    'Shrink image if outside of slide borders 
    If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then 
    ppApp.ActiveWindow.Selection.ShapeRange.Width = 700 
    End If 

    If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then 
    ppApp.ActiveWindow.Selection.ShapeRange.Height = 600 
    End If 

    ' Align the pasted range 
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 


    ' Clean up 
    Set PPSlide = Nothing 
    Set ppPres = Nothing 
    Set ppApp = Nothing 
    End If 

End Sub