PDA

View Full Version : Copying charts from all Excel worksheets onto Powerpoint slides



waqar.b85
05-01-2018, 11:31 AM
Hello experts,

I have the code below that works well to export excel graphs onto powerpoint. But where I am stuck is that it only exports the graphs from the active worksheet.

How can I make it cycle through all the whole workbook and then export the graphs sheet by sheet?

Thanks.




Option Base 1


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
Dim pptPres As PowerPoint.Presentation


'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
strFileToOpen = Application.GetOpenFilename(FileFilter:="Powerpoint Files *.pptx (*.pptx),")
If strFileToOpen = False Then Exit Sub
Set newPowerPoint = New PowerPoint.Application
newPowerPoint.Visible = True
Set pptPres = newPowerPoint.Presentations.Open(Filename:=strFileToOpen, ReadOnly:=msoFalse)


If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If


'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For i = 1 To ActiveSheet.ChartObjects.Count
Set cht = ActiveSheet.ChartObjects(i)

'Add a new slide where we will paste the chart
chartNum = (i - 1) Mod 4
If chartNum = 0 Then
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
End If




newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Sl ides.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
If chartNum = 0 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
ElseIf chartNum = 1 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 528
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
ElseIf chartNum = 2 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
Else
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 528
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
End If


newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 300
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 350


Next


Set activeSlide = Nothing
Set newPowerPoint = Nothing
Set pptPres = Nothing


End Sub

duongduythao
05-01-2018, 08:44 PM
Me too. I am doing project and make power point need to copy some excel information through but not?

JKwan
05-03-2018, 07:17 AM
this will cycle all worksheets within the active workbook


Option Base 1
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
Dim pptPres As PowerPoint.Presentation
Dim WB As Workbook
Dim WS As Worksheet
'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
strFileToOpen = Application.GetOpenFilename(FileFilter:="Powerpoint Files *.pptx (*.pptx),")
If strFileToOpen = False Then Exit Sub
Set newPowerPoint = New PowerPoint.Application
newPowerPoint.Visible = True
Set pptPres = newPowerPoint.Presentations.Open(Filename:=strFileToOpen, ReadOnly:=msoFalse)


If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If

Set WB = ThisWorkbook
For Each WS In WB.Worksheets
MsgBox WS.Name
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For i = 1 To ActiveSheet.ChartObjects.Count
Set cht = ActiveSheet.ChartObjects(i)

'Add a new slide where we will paste the chart
chartNum = (i - 1) Mod 4
If chartNum = 0 Then
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
End If

newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Sl ides.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
If chartNum = 0 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
ElseIf chartNum = 1 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 528
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 70
ElseIf chartNum = 2 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
Else
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 528
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
End If


newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 300
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 350
Next
Next WS
Set WS = Nothing
Set WB = Nothing
Set activeSlide = Nothing
Set newPowerPoint = Nothing
Set pptPres = Nothing
End Sub