[英]excel charts to powerpoint vba
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. 我需要做的是将Activesheet而不是Activesheet更改为整个工作簿,因此请复制工作簿中的所有图表。 I tried introducing what I use to read through the workbook and delete all sheets :
我尝试介绍我用来通读工作簿并删除所有工作表的内容:
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 谢谢
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. 我现在正在尝试做类似的事情,查看上面的代码,您有3个For Each循环,但我相信您应该只有2个。 One to Loop over the sheets and a second to loop over each chart in the sheet.
一个循环在工作表上,第二个循环在工作表中的每个图表上。
` Sub SelectedSheetsPowerPoint() `Sub 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次后我将其关闭。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.