![](/img/trans.png)
[英]VBA: Excel to Powerpoint Copy + Paste Selected Charts into Active PPT Slide
[英]VBA: Copy + Paste Selected Charts from Excel to Powerpoint
我希望将选定的图表从Excel 2010复制并粘贴为Powerpoint 2010,并将它们作为Microsoft Excel图表对象格式粘贴到活动的 PPT幻灯片中。 理想情况下,我希望能够将这些图表放置在活动的Powerpoint幻灯片上的特定位置。 我搜寻了网络,但即使不是大多数解决方案,所有解决方案都是将工作表中的所有幻灯片随机粘贴到PPT幻灯片上。 我什至没有代码,但是如果有人可以提供帮助,那将非常棒。 谢谢!
好吧,这是东西:这是我以前写的pptGenerator类。 在我的场景中,我想右键单击工作簿中的特定图表,在自定义上下文菜单中将“复制到演示文稿”作为选项,然后在同一演示文稿或新演示文稿的后续幻灯片中添加后续图表。 这些图表是在另一个类中捕获的,以便创建上下文菜单,并在传递给幻灯片时将其自身复制到幻灯片。 下面是经过稍微修改和剥离的版本,该版本应该可以帮助您通过编辑此类来解决您的特定情况。
在类模块中:
'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
在我的“工厂”模块中。 常规代码模块:
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
因此,从何处以及如何获得所选图表是另一回事,但是,只要您设法从工作簿的ChartObject或Slide中选择图表,并将其作为参数传递给上面,您应该能够根据以下内容进行修复根据您自己的规格。
除了我的建议外,请在MSDN上检查您的Powerpoint版本的VBA参考。
所以这是一个对我有用的解决方案。 宏复制+将选定的范围或图表粘贴到活动的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.