用VBA将带数据的Excel图表粘贴到PowerPoint中
答:TL,;DR:粘贴带有嵌入数据的图表需要很长时间,因此您必须安装一个延迟,以防止vba在粘贴操作完成之前移动 问题:我正在尝试将包含嵌入数据的excel图表粘贴到powerpoint演示文稿中。我唯一挂断的事情是在ppt中参考和定位图表,一旦它被粘贴用VBA将带数据的Excel图表粘贴到PowerPoint中,excel,vba,charts,powerpoint,Excel,Vba,Charts,Powerpoint,答:TL,;DR:粘贴带有嵌入数据的图表需要很长时间,因此您必须安装一个延迟,以防止vba在粘贴操作完成之前移动 问题:我正在尝试将包含嵌入数据的excel图表粘贴到powerpoint演示文稿中。我唯一挂断的事情是在ppt中参考和定位图表,一旦它被粘贴 Dim newPowerPoint As PowerPoint.Application ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartAre
Dim newPowerPoint As PowerPoint.Application
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Copy
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
因为我需要将多个图表粘贴到单个幻灯片中,所以需要重新定位它们。我试着用这段代码做到这一点:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0
但我总是遇到错误:“对象“选择”的“形状”方法失败”
特别奇怪的是,从头到尾运行代码会导致此错误,但使用F8键单步执行代码不会导致此错误
我已经尝试了所有我能想到的方法来移动这个图表,但是我完全被卡住了。有人知道我怎么做吗?另外,请记住,图表中必须包含数据(我不能将图表粘贴为图片,我强烈希望数据不被链接)
谢谢
史蒂夫
使用多个图表对象编辑新修改的代码。我需要添加一个if条件:
If activeSlide.Shapes.Count = 1 Then
GoTo NextiLoop
End If
对于其他图表对象,因为延迟粘贴图表2会使循环名称图表1为“pptcht2”,因为图表2尚不存在
Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht1 As Excel.ChartObject
Dim Data As Excel.Worksheet
Dim pptcht1 As PowerPoint.Shape
Dim iLoopLimit As Long
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add _
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide _
newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides _
(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Share0110")
Set cht2 = Data.ChartObjects("SOW0110")
Set cht3 = Data.ChartObjects("PROP0110")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht1
.Left = 25
.Top = 150
End With
iLoopLimit = 0
'ActiveSheet.ChartObjects("Chart 2").Activate
'Set Data = ActiveSheet
cht2.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
If activeSlide.Shapes.Count = 1 Then
GoTo NextiLoop
End If
Set pptcht2 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht2 Is Nothing Then Exit Do
NextiLoop:
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht2
.Left = 275
.Top = 150
End With
iLoopLimit = 0
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
编辑:旧的不工作代码:
Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Chart 1")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
Set pptcht1 = newPowerPoint.ActiveWindow.Selection
With pptcht1
.Left = 0
End With
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
选项显式
这将迫使您声明所有变量。您有很多未声明的变量,包括一对几乎与您声明的少数变量相同的变量。然后转到VBA的“工具”菜单>“选项”,并检查对话框第一个选项卡上的“需要变量声明”,该选项卡将在每个新模块的顶部显示Option Explicit
设置pptcht1=activeSlide.Shapes(activeSlide.Shapes.Count)
newPowerPoint.commandbar.ExecuteMso(“粘贴Excel图表目标”)
所以我拼凑了一个小循环,尝试将变量设置为形状,并一直循环,直到形状创建完成
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
在少量测试中,我发现循环必须运行20到60次。我还崩溃了几次PowerPoint。奇怪
我相信有更好的方法可以粘贴复制的图表并保留幻灯片的颜色主题,但我不知道有什么方法
AppActivate(“Microsoft PowerPoint”)
改用这个:
AppActivate newPowerPoint.Caption
你好,谢谢你的回复。我已经试着给我的图表标注尺寸,但我似乎找不到一种可以让我定位它的昏暗。我收到错误:“selection.shaperange:请求无效。当前未选择任何合适的内容。”我已尝试Powerpoint.Chart、.object、.shapes。有什么建议吗?我在上得到了一个类型不匹配。左=0。你能指定我应该怎样调暗床单吗?我将在上面发布我的当前代码。当您在变量XD中使用
active
并将所有对象设置为variables时,会很混乱<代码>设置数据=ActiveSheet错误。当你在应用程序之间切换时,很容易忘记什么是“活动的”。这意味着无论选择什么,设置pptcht1=newPowerPoint.ActiveWindow。选择可能是错误的,这意味着你的左
将无法工作。有意义吗?另外,activewindow
上的.shaperage
。您需要一个shaperange对象。我不知道如何在不使用活动功能的情况下引用刚刚粘贴到powerpoint中的图表。非常感谢您的详细回答!我现在没有带代码,但我一定会在明天早上试用,然后回复-史蒂夫
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht1 As Excel.ChartObject
Dim Data As Excel.Worksheet
Dim pptcht1 As PowerPoint.Shape
Dim iLoopLimit As Long
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add _
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide _
newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides _
(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Chart 1")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht1
.Left = 0
End With
AppActivate newPowerPoint.Caption
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub`