VBA：复制+将所选图表从Excel粘贴到Powerpoint
我正在寻找作为Microsoft Excel图表对象格式复制和粘贴选定图表从Excel 2010到Powerpoint 2010到活动 PPT幻灯片。 理想情况下，我希望能够将这些图表放置在有效的Powerpoint幻灯片上的特定位置。 我已经搜寻了网页，但是如果不是大多数解决scheme，所有的幻灯片都会被粘贴到PPT幻灯片上。 我甚至没有代码，但如果任何人都可以提供帮助，那就太棒了。 谢谢！
那么，这是一些东西：这是我写了一段时间的pptGenerator类。 在我的场景中，我想右键单击工作簿中的特定图表，在“自定义上下文菜单”中select“复制到演示文稿”，然后在相同的演示文稿或后续幻灯片中添加后续图表。 这些图表是在另一个类中捕获的，以创build上下文菜单，并将其自身复制到传递给它的幻灯片中。 下面是一个稍微修改和剥离的版本，应该通过编辑这个类来帮助你解决你的具体情况。
在一个Class模块中：
'PowerPoint Generator class - Rik Sportel 'Maintains a PowerPoint application for Excel workbook. Private WithEvents pptApp As PowerPoint.Application Private ppt As PowerPoint.Presentation Private pptPresentations As Collection 'Collection to add presentations to Private p_currentPresentation As Boolean 'Make sure you don't add slides if there is no presentation. Public Property Get CurrentPresentation() As Boolean CurrentPresentation = p_currentPresentation End Property 'Initialization Private Sub Class_Initialize() p_currentPresentation = False Set pptApp = New PowerPoint.Application Set pptPresentations = New Collection End Sub 'Termination Private Sub Class_Terminate() Set pptPresentations = Nothing Set pptApp = Nothing End Sub 'Creates a new Presentation in the powerpoint app, and adds it to the pptPresentations collection. Add methods later to cycle through them. Public Sub NewPresentation() Set ppt = pptApp.Presentations.Add pptPresentations.Add ppt 'Create presentation and use image stored within the current workbook as a background for it. ThisWorkbook.Worksheets("BGItems").Shapes(1).Copy 'Copy the background ppt.Windows(1).ViewType = ppViewSlideMaster ppt.Windows(1).View.Paste 'Paste the background ppt.Windows(1).ViewType = ppViewNormal p_currentPresentation = True End Sub 'Add a slide to the presentation, place passed chart on it. Public Sub AddSlide(chartForSlide As Chart) Dim nSlide As PowerPoint.Slide Dim nChart As PowerPoint.Shape 'Create a new slide with the chart on it. Set nSlide = pptApp.ActivePresentation.Slides.Add(1, ppLayoutBlank) chartForSlide.ChartArea.Copy nSlide.Shapes.Paste 'Paste the chart Set nChart = nSlide.Shapes(1) 'Position the chart With nChart .Left = ppt.PageSetup.SlideWidth / 10 .top = ppt.PageSetup.SlideHeight / 10 .Width = ppt.PageSetup.SlideWidth / 100 * 80 .Height = ppt.PageSetup.SlideHeight / 2 End With Set nChart = Nothing Set nSlide = Nothing End Sub 'Make sure to keep track of presentations properly if users interact with 'powerpoint in unexpected ways. Capture event and make sure the presentation object you write to will still exist. Private Sub pptApp_PresentationClose(ByVal Pres As PowerPoint.Presentation) For i = pptPresentations.Count To 1 Step -1 If pptPresentations.Item(i) Is Pres Then pptPresentations.Remove i End If Next i If Pres Is ppt Then Set ppt = Nothing p_currentPresentation = False End If End Sub 在我的“工厂”模块。 一个常规的代码模块：
Public Sub GetPowerpoint() If pptApp Is Nothing Then Set pptApp = New pptGenerator End Sub
如何使用：
'Pass a chart + optionally if it has to be a new presentation: Public Sub CopyChartToPpt(tChart As Chart, Optional newPres As Boolean) GetPowerpoint If pptApp.CurrentPresentation = False Then pptApp.NewPresentation If newPres = True Then pptApp.NewPresentation pptApp.AddSlide tChart End Sub
因此，在何处以及如何获得选定的图表是另一回事，但只要您设法从工作簿中的ChartObject或Slide中select图表，并将其作为parameter passing给上面，则应该能够根据到你自己的规格。
除了我的build议，将是在MSDN检查您的PowerPoint版本的VBA参考。
所以这里有一个为我工作的解决scheme。 macros复制+将选定的范围或图表粘贴到活动的PowerPoint幻灯片中。 我想这样做的原因是，每个季度/每个月我们都会为我们的客户生成报告，这有助于减less复制粘贴所需的时间，并使套牌看起来不错。 希望这可以帮助任何人做出大量的PPT！
'Export and position into Active Powerpoint 'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference 'Identifies selection as either range or chart Sub ButtonToPresentation() If TypeName(Selection) = "Range" Then Call RangeToPresentation Else Call ChartToPresentation End If End Sub Sub RangeToPresentation() Dim PPApp As PowerPoint.Application Dim PPPres As PowerPoint.Presentation Dim PPSlide As PowerPoint.Slide 'Error message if range is not selected If Not TypeName(Selection) = "Range" Then MsgBox "Please select a worksheet range and try again." Else 'Reference existing instance of PowerPoint Set PPApp = GetObject(, "Powerpoint.Application") 'Reference active presentation Set PPPres = PPApp.ActivePresentation 'Reference active slide Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex) 'Copy the range as a picture Selection.CopyPicture Appearance:=xlScreen, _ Format:=xlBitmap 'Paste the range PPSlide.Shapes.Paste.Select '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 Sub ChartToPresentation() 'Uses Late Binding to the PowerPoint Object Model 'No reference required to PowerPoint Object Library Dim PPApp As Object 'As PowerPoint.Application Dim PPPres As Object 'As PowerPoint.Presentation Dim PPSlide As Object 'As PowerPoint.Slide 'Error message if chart is not selected If ActiveChart Is Nothing Then MsgBox "Please select a chart and try again." Else 'Reference existing instance of PowerPoint Set PPApp = GetObject(, "Powerpoint.Application") 'Reference active presentation Set PPPres = PPApp.ActivePresentation 'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide 'Reference active slide Set PPSlide = PPPres.Slides _ (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex) 'Copy chart as a picture ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _ Format:=xlPicture 'Paste chart PPSlide.Shapes.Paste.Select 'Align pasted chart 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