How to Generate Power Point Presentation Slides for each Chart in Active Sheet with Excel VBA Macro

Excel VBA Macro to Generate Power Point Presentation Slides for each Chart in Active Sheet.
Suppose In a Workbook Sheet if we have some charts with Titles and Notes.

Now if you want the Generate the Power Point Slides for each Chart with Titles and Notes , and we can use the following Macro.
This Macro will generate the Slide for each Chart in Active Sheet and Save the Presentation in active Workbook Path with Workbook Name.
------------------------------------------------------------------
Sub Create_PPT_Charts_with_Titles_Comments_Activesheet()
 Dim New_PowerPoint As Object
 Dim PPT_Present As Powerpoint.Presentation
 Dim ActiveSlide As Powerpoint.Slide
 Dim Cht As Excel.ChartObject
     
 SavePath = ThisWorkbook.Path
 Present_Name = ThisWorkbook.Name
    
On Error Resume Next
   'Set New_PowerPoint = GetObject(, "PowerPoint.Application")
    Set New_PowerPoint = CreateObject("PowerPoint.Application")
On Error GoTo 0
     
If New_PowerPoint Is Nothing Then
        Set New_PowerPoint = New Powerpoint.Application
End If

If New_PowerPoint.Presentations.Count = 0 Then
        Set PPT_Present = New_PowerPoint.Presentations.Add
       'Set PPT_Present = New_PowerPoint.Presentations.Open                                                                                      ("C:\Users\Tamatam\Downloads\Temp.pptx")
End If     
    New_PowerPoint.Visible = True    
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each Cht In ActiveSheet.ChartObjects
        
New_PowerPoint.ActivePresentation.Slides.Add       New_PowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
New_PowerPoint.ActiveWindow.View.GotoSlide New_PowerPoint.ActivePresentation.Slides.Count
Set ActiveSlide = New_PowerPoint.ActivePresentation.Slides                                                                            (New_PowerPoint.ActivePresentation.Slides.Count)

'Set the Title of the slide the same as the Title of the Chart
ActiveSlide.Shapes(1).TextFrame.TextRange.Text = Cht.Chart.ChartTitle.Text
   'ActiveSlide.Shapes(1).TextFrame.TextRange.Font.Size = 30
   
'Add the Comments in the Text box of the slide based on the Region Chart
ActiveSlide.Shapes(2).Width = 180
ActiveSlide.Shapes(2).Left = 490
    
'If the Chart is the "US" Chart, then enter the appropriate Notes
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)
        ActiveSlide.Shapes(2).TextFrame.TextRange.Font.Size = 18
'Else if the Chart is the "UK" Chart, then enter the appropriate Notes
ElseIf InStr(ActiveSlide.Shapes(1).TextFrame.TextRange.Text, "UK") 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)
        ActiveSlide.Shapes(2).TextFrame.TextRange.Font.Size = 18
End If
    
'Deleting Title and Body Text boxes from PPT Slide if Not require.
   'ActiveSlide.Shapes(1).Delete 'Deleting shape(1)from PPTslide
   'ActiveSlide.Shapes(1).Delete 'Deleting shape(2) from PPTslide
        
'Copy the chart and paste it into the PowerPoint as a Picture on Slide
    Cht.Select
    ActiveChart.ChartArea.Copy
    ActiveSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
    
'<< Pasting with Source Formatting >>
             PPT_Slide.Select
             PPT_Slide.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

'Adjusting the positioning of the Chart on Powerpoint Slide
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Width = 455
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 360
    
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 35
 New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
    
Next Cht

'Saving the Presentation
PPT_Present.SaveAs SavePath & "\" & Present_Name & ".pptx"

PPT_Present.Close
Set PPT_Present = Nothing
Set ActiveSlide = Nothing
'Closing the Powepoint Application Window
New_PowerPoint.Quit
Set New_PowerPoint = Nothing

MsgBox " Each Chart from Active is Printed on PowerPoint Slides", vbOKOnly, "PPTs Generated Successfully"
End Sub

--------------------------------------------------------------------------------------------------------

Thanks, TAMATAM ; Business Intelligence & Analytics Professional

--------------------------------------------------------------------------------------------------------