将Excel图表和表格复制到Powerpoint

Question

我正在尝试在excel中创建图表和表格，然后通过PowerPoint VBA宏将它们全部复制到PowerPoint中的幻灯片中。 我已经创建了图表和表格，但是在复制和粘贴它们时遇到了问题。 我不熟悉这样做的语法。 由于我是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