且构网

分享程序员开发的那些事...
且构网 - 分享程序员编程开发的那些事

VBA:将所选图表从Excel复制+粘贴到Powerpoint

更新时间:2023-02-14 08:39:31

所以这里有一个为我工作的解决方案。将宏复制+粘贴选择范围图表进入活动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