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
Suppose In a Workbook Sheet if we have some charts with Titles and Notes.
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
--------------------------------------------------------------------------------------------------------
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.