將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