将Excel图表和表格复制到Powerpoint

我正在尝试在Excel中创build图表和表格，然后通过PowerPoint VBAmacros将其复制到幻灯片中。 我有创build的图表和表格，但我有复制和粘贴它们的问题。 我不熟悉这样做的语法。 任何帮助将不胜感激，因为我是新的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