Excel VBA Macro to Generate PowerPoint Slides for each Chart in Active Sheet
Suppose In a Workbook Sheet if we have some Charts.
Now if you want the Generate the Power Point Slides for each Chart , 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_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)
'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
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 = 620
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 400
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 55
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 65
Next Cht
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
Suppose In a Workbook Sheet if we have some Charts.
Now if you want the Generate the Power Point Slides for each Chart , 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_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)
'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
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 = 620
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 400
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 55
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 65
Next Cht
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
--------------------------------------------------------------------------------------------------------
No comments:
Post a Comment
Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.