将 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