將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