[英]VBA: Excel to Powerpoint Copy + Paste Selected Charts into Active PPT Slide
我希望将 Excel 中选定的图表复制并粘贴到活动的PPT 幻灯片中。 我有一个代码可以创建一个新的工作簿并粘贴工作簿中的所有图表,但希望将命令限制为仅选定的图表。 这是代码:
Option Explicit
Sub CopyChartsToPowerPoint()
'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long
'Powerpoint Application objects declaration
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation
pptApp.ActiveWindow.ViewType = ppViewSlide
lngSlideKount = 0
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objChart
'Copy + paste chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
pptSld.Shapes.Paste.Select
'Coordinates will change depending on chart
With pptApp.ActiveWindow.Selection.ShapeRange
.Left = 456
.Top = 20
End With
End With
lngSlideKount = lngSlideKount + 1
Next objChartObject
End If
Next ws
' Now check CHART sheets:
For Each objCht In ActiveWorkbook.Charts
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objCht
'Copy chart object as picture
.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste.Select
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
lngSlideKount = lngSlideKount + 1
Next objCht
'
'Activate PowerPoint application
pptApp.ActiveWindow.ViewType = ppViewNormal
pptApp.Visible = True
pptApp.Activate
If lngSlideKount > 0 Then
If lngSlideKount = 1 Then
MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
Else
MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
End If
End If
End Sub
感谢大家的帮助!
Excel for Charts 中似乎没有一个很好的简单 .IsSelected 属性,因此您需要像在此函数中一样分析选择,您可以从您的过程中调用该函数以获取所选图表的集合(测试以确保它不是 Nothing在处理集合中的每个项目之前):
Option Explicit
' ***********************************************************
' Purpose: Get a collection of selected chart objects.
' Inputs: None.
' Outputs: Returns a collection of selected charts.
' Author: Jamie Garroch
' Company: YOUpresent Ltd. http://youpresent.co.uk/
' ***********************************************************
Function GetSelectedCharts() As Collection
Dim oShp As Shape
Dim oChartObjects As Variant
Set oChartObjects = New Collection
' If a single chart is selected, the returned type is ChartArea
' If multiple charts are selected, the returned type is DrawingObjects
Select Case TypeName(Selection)
Case "ChartArea"
oChartObjects.Add ActiveChart
Case "DrawingObjects"
For Each oShp In Selection.ShapeRange
If oShp.Type = msoChart Then
Debug.Print oShp.Chart.Name
oChartObjects.Add oShp.Chart
End If
Next
End Select
Set GetSelectedCharts = oChartObjects
Set oChartObjects = Nothing
End Function
所以这是一个对我有用的解决方案。 宏复制 + 将选定范围或图表粘贴到活动 PowerPoint 幻灯片中的某个位置。 我想这样做的原因是每个季度/每月我们都会为我们的客户生成报告,这有助于减少复制 + 粘贴所需的时间,并使甲板看起来不错。 希望这对制作大量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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.