Excel VBA Macro to change Pivot Chart Slicer, Filter Item dynamically and Print the Chart of each Slicer Item on Power Point Slides
Let us Suppose there is Pivot Chart with Slicer in Active Sheet as Shown below :
Now if we want to apply the Filter for each Slicer Item of Sales_Period and Generate the Charts for each Period , which means Chart for Q1-2014,Q2-2014...Q4-2014.
We can do using the following Macro.
Sub Create_PPT_Chart_Foreach_SlicerItem()
Dim New_PowerPoint As Object
Dim PPT_Present As PowerPoint.Presentation
Dim ActiveSlide As PowerPoint.Slide
Dim SL_Item As SlicerItem
Dim WB As Object
SavePath = ThisWorkbook.Path
Present_Name = ThisWorkbook.Name
Set WB = ActiveWorkbook
Chart_Name = "Quarterly_Sales" '--This is the Chart Name
Slicer_Name = "Slicer_Sales_Period1" '--This is the Slicer 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\Desktop\Temp\Sales_Deck.pptx")
End If
New_PowerPoint.Visible = True
ActiveSheet.ChartObjects(Chart_Name).Activate
X = WB.SlicerCaches(Slicer_Name).SlicerItems.Count
WB.SlicerCaches(Slicer_Name).ClearManualFilter
'Loop through Active Chart Slicer Filter Items applying Filter to Generate Chart and Paste into the PowerPoint Slide
For Y = 1 To X
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
Quarter = WB.SlicerCaches(Slicer_Name).SlicerItems(Y).Name
'Looping through each Slicer Item and Checking condition to Select or Deselect
For Each SL_Item In WB.SlicerCaches(Slicer_Name).SlicerItems
If SL_Item.Name = Quarter Then
SL_Item.Selected = True
Else
SL_Item.Selected = False
End If
Next SL_Item
ActiveSheet.ChartObjects(Chart_Name).Activate
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 = 630
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 450
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50
WB.SlicerCaches(Slicer_Name).ClearManualFilter
Next Y
'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 "Chart for each Period is Printed on PowerPoint Slides", vbOKOnly, "PPTs Generated Successfully"
End Sub
Let us Suppose there is Pivot Chart with Slicer in Active Sheet as Shown below :
We can do using the following Macro.
Sub Create_PPT_Chart_Foreach_SlicerItem()
Dim New_PowerPoint As Object
Dim PPT_Present As PowerPoint.Presentation
Dim ActiveSlide As PowerPoint.Slide
Dim SL_Item As SlicerItem
Dim WB As Object
SavePath = ThisWorkbook.Path
Present_Name = ThisWorkbook.Name
Set WB = ActiveWorkbook
Chart_Name = "Quarterly_Sales" '--This is the Chart Name
Slicer_Name = "Slicer_Sales_Period1" '--This is the Slicer 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\Desktop\Temp\Sales_Deck.pptx")
End If
New_PowerPoint.Visible = True
ActiveSheet.ChartObjects(Chart_Name).Activate
X = WB.SlicerCaches(Slicer_Name).SlicerItems.Count
WB.SlicerCaches(Slicer_Name).ClearManualFilter
'Loop through Active Chart Slicer Filter Items applying Filter to Generate Chart and Paste into the PowerPoint Slide
For Y = 1 To X
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
Quarter = WB.SlicerCaches(Slicer_Name).SlicerItems(Y).Name
'Looping through each Slicer Item and Checking condition to Select or Deselect
For Each SL_Item In WB.SlicerCaches(Slicer_Name).SlicerItems
If SL_Item.Name = Quarter Then
SL_Item.Selected = True
Else
SL_Item.Selected = False
End If
Next SL_Item
ActiveSheet.ChartObjects(Chart_Name).Activate
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 = 630
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Height = 450
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
New_PowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50
WB.SlicerCaches(Slicer_Name).ClearManualFilter
Next Y
'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 "Chart for each Period 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.