更新时间: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