将Excel图表和表格复制到Powerpoint

Question

I am trying to create charts and tables in excel and then copy them to slides in powerpoint all through a PowerPoint VBA macro. I have the charts and tables created but I am having an issue with copying and pasting them over. I am not familiar with the syntax to do so. Any help would be greatly appreciated as I am new to 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

This sub will get you on your way. It needs some tweaks but this can copy over a range into a 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