Hi All,
I was looking for a code that can create PPT from Excel and I found below code in google and it is working fine. However I want to add two more functions to it, like,
1. It should create a Cover page for the presentation taking text value from Title, Cell A1
2. On slide two, it should create a "Index" (hyperlinked) taking the Slide titles
Please note: I am attaching a sample file as for your reference that will create two slides (one slide for each chart), however my final excel file might have 100+ charts which means 100+ slides
Sub CreatePowerPoint()
Dim newPowerPoint As PowerPoint.Application
Dim Activeslide As PowerPoint.Slide
Dim cht As Excel.ChartObject
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
newPowerPoint.Visible = True
For Each cht In ActiveSheet.ChartObjects
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)
cht.Select
ActiveChart.ChartArea.Copy
Activeslide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
Activeslide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
Activeslide.Shapes(2).Width = 200
Activeslide.Shapes(2).Left = 505
If InStr(Activeslide.Shapes(1).TextFrame.TextRange.Text, "US") Then
Activeslide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine
Activeslide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)
Activeslide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J9").Value & vbNewLine)
ElseIf InStr(Activeslide.Shapes(1).TextFrame.TextRange.Text, "Renewable") Then
Activeslide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine
Activeslide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)
Activeslide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)
End If
Activeslide.Shapes(2).TextFrame.TextRange.Font.Size = 16
Next
AppActivate ("PowerPoint")
Set Activeslide = Nothing
Set newPowerPoint = Nothing
End Sub