VBA：将所选图表从 Excel 复制并粘贴到 Powerpoint
VBA: Copy + Paste Selected Charts from Excel to Powerpoint
我希望将 选定的图表 从 Excel 2010 复制并粘贴到 Powerpoint 2010 作为 Microsoft Excel 图表对象格式到 active PPT幻灯片。理想情况下，我希望能够将这些图表放在活动的 Powerpoint 幻灯片上的特定位置。我在网上搜索过，但所有（如果不是大多数）解决方案都是将 sheet 中的所有幻灯片随机粘贴到 PPT 幻灯片上。我什至没有代码，但如果有人可以提供帮助，那就太棒了。谢谢！
好吧，这是一些东西：这是我以前写的 pptGenerator-class。
在我的场景中，我想右键单击工作簿中的特定图表，将 "Copy to presentation" 作为自定义上下文菜单中的选项，然后在同一演示文稿或新演示文稿中的后续幻灯片上添加后续图表。
这些图表是在另一个 class 中捕获的，以便创建上下文菜单，并在传递给幻灯片时将其自身复制到幻灯片中。
下面是一个稍微修改和剥离的版本，应该可以帮助您通过编辑此 class.
来解决您的具体情况
在 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
在我的 "factory" 模块中。常规代码模块：
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
因此，从何处以及如何获取 selected 图表是另一回事，但只要您设法 select 来自工作簿中的 ChartObject 或 Slide 的图表，并将其作为上面的一个参数，你应该可以根据自己的规格来修复它。
除我的建议外，我还建议您在 MSDN 上查看 VBA 参考资料，了解您的 powerpoint 版本。
这是一个对我有用的解决方案。宏复制+粘贴selected范围or图表到活动PowerPoint幻灯片中的某个位置。我想这样做的原因是我们每次 quarter/month 都会为我们的客户生成报告，这有助于减少复制 + 粘贴所需的时间并使套牌看起来更漂亮。希望这对制作大量 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
我希望将 选定的图表 从 Excel 2010 复制并粘贴到 Powerpoint 2010 作为 Microsoft Excel 图表对象格式到 active PPT幻灯片。理想情况下，我希望能够将这些图表放在活动的 Powerpoint 幻灯片上的特定位置。我在网上搜索过，但所有（如果不是大多数）解决方案都是将 sheet 中的所有幻灯片随机粘贴到 PPT 幻灯片上。我什至没有代码，但如果有人可以提供帮助，那就太棒了。谢谢！
好吧，这是一些东西：这是我以前写的 pptGenerator-class。 在我的场景中，我想右键单击工作簿中的特定图表，将 "Copy to presentation" 作为自定义上下文菜单中的选项，然后在同一演示文稿或新演示文稿中的后续幻灯片上添加后续图表。 这些图表是在另一个 class 中捕获的，以便创建上下文菜单，并在传递给幻灯片时将其自身复制到幻灯片中。 下面是一个稍微修改和剥离的版本，应该可以帮助您通过编辑此 class.
来解决您的具体情况在 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
在我的 "factory" 模块中。常规代码模块：
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
因此，从何处以及如何获取 selected 图表是另一回事，但只要您设法 select 来自工作簿中的 ChartObject 或 Slide 的图表，并将其作为上面的一个参数，你应该可以根据自己的规格来修复它。
除我的建议外，我还建议您在 MSDN 上查看 VBA 参考资料，了解您的 powerpoint 版本。
这是一个对我有用的解决方案。宏复制+粘贴selected范围or图表到活动PowerPoint幻灯片中的某个位置。我想这样做的原因是我们每次 quarter/month 都会为我们的客户生成报告，这有助于减少复制 + 粘贴所需的时间并使套牌看起来更漂亮。希望这对制作大量 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