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