VBA：将所选图表从Excel复制+粘贴到Powerpoint [英] VBA: Copy + Paste Selected Charts from Excel to Powerpoint

问题描述

我正在将Microsoft Excel图表对象格式化为活动 PPT幻灯片，将Excel中的所选图表复制并粘贴到Powerpoint 2010。理想情况下，我希望能够将这些图表放置在活动的Powerpoint幻灯片上的特定位置。我已经扫描了网络，但是如果不是大多数解决方案都是将PPT幻灯片随机粘贴在一张纸上的所有幻灯片。我甚至没有代码，但如果有人可以帮助，那将是非常棒的。谢谢！

I am looking to copy and paste selected charts from Excel 2010 to Powerpoint 2010 as Microsoft Excel Chart Object formats into an active PPT slide. Ideally, I would like to be able to place these charts into specific positions on the active Powerpoint slide. I've scrounged the web but all if not most solutions are for all slides in a sheet to be pasted randomly on a PPT slide. I don't even have a code but if anyone can help, that would be awesome. Thanks!

推荐答案

所以这里有一个为我工作的解决方案。将宏复制+粘贴选择范围或图表进入活动PowerPoint幻灯片到某一位置。我想这样做的原因是每个季度我们为客户生成报告，这有助于减少复制+粘贴所需的时间，并使甲板看起来不错。希望这有助于任何人制作大量PPT！

So here's a solution that worked for me. The macro copy + pastes selected range or chart into the active PowerPoint slide into a certain position. This reason I wanted to do this is that each quarter/month we generate reports for our clients and this helps to reduce the time required for copying + pasting and making the deck look nice. Hope this helps anyone else who make a ton of PPTs!

'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

这篇关于VBA：将所选图表从Excel复制+粘贴到Powerpoint的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！