excel图表到powerpoint vba
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/9840608/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
excel charts to powerpoint vba
提问by Zenaphor
I have a standard code that prints all charts in your active sheet to a new powerpoint application:
我有一个标准代码，可以将活动工作表中的所有图表打印到新的 powerpoint 应用程序中：
Sub CreatePowerPoint()
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
'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
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
'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)
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
Next
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
What I need to do is change the instead of activesheet to whole workbook, so copy over all charts in workbook. I tried introducing what I use to read through the workbook and delete all sheets :
我需要做的是将而不是 activesheet 更改为整个工作簿，因此复制工作簿中的所有图表。我尝试介绍我用来阅读工作簿并删除所有工作表的内容：
Sub ClearCharts()
Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
chtObj.Delete
Next
Next
End Sub
but it runs and doesnt copy over the charts when I try and edit the activesheet line. Any ideas would be appreciated for me to progress.
但是当我尝试编辑活动表行时，它会运行并且不会复制图表。任何想法都会让我进步。
Thankyou
谢谢
采纳答案by Zenaphor
` Sub SelectedSheetsPowerPoint()
` 子 SelectedSheetsPowerPoint()
Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
wsItem.Activate
'~~> Code here to copy it to the poerpoint
'~~> Same for deleting it
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
'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
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
'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)
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 75
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 120
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
'loop through each chart in !!activesheet!! and move each into a new slide!
Next
'start pp, can add preset headings for power point here
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
DoEvents
Next
Next
End Sub
`
`
it runs through and puts out all graphs but it doesn't stop, it will just keep copying and looping through all the sheets until I closed it out after it copied about 15 times.
它运行并输出所有图形，但它不会停止，它只会继续复制和循环遍历所有工作表，直到我在复制大约 15 次后将其关闭。
回答by Mark
I'm trying to do a similar thing at the moment, looking at the code above you have 3 For Each loops but you should only have 2 I believe. One to Loop over the sheets and a second to loop over each chart in the sheet.
我目前正在尝试做类似的事情，查看上面的代码，您有 3 个 For Each 循环，但我相信您应该只有 2 个。一个用于循环工作表，第二个用于循环工作表中的每个图表。
回答by Siddharth Rout
You have to activate the sheet before you export the chart. I have faced this problem in the past when exporting the charts.
您必须在导出图表之前激活工作表。我过去在导出图表时遇到过这个问题。
Try this
尝试这个
Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
wsItem.Activate
'~~> Code here to copy it to the poerpoint
'~~> Same for deleting it
DoEvents
Next
Next
