Create PPT from Excel with Cover Page and Index

[amitmodi_mrt]

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.Sl ides.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