clsCht()
Add Drilldown to Pivot Charts
Add-in makes adding drilldown and full screen display to executive dashboards insanely simple.
In general, dashboards are better in Power BI. One reason is Power BI supports click to drilldown and full screen charts. That said, there are times when adding a dashboard to a model is simpler with Excel, rather than splitting the project with calculations in Excel and presentation in Power BI. Besides, adding this to Excel projects is insanely simple.
Drilldown:
Drilldown is an executive dashboard expectation. It allows us to discover why a chart bar, line, or slice is bigger, or smaller than expected. For many years, Excel's charts did not support drilldown at all. Now, if we left click a chart element (usually twice, slowly, because the first time selects all chart elements), then right click it, we will see a "Show Detail" option. If we select that, Excel creates a new worksheet and reveals the underlying data. While that works, that is just way too complicated for most dashboard users (and how many of us knew that option existed?). It also leaves junk worksheets behind for us to clean up. We need a simpler solution that cleans up after itself.
With this class, we can click a chart bar, area, point or slice and display supporting data. When we want to return to our chart, click a "back" button which removes the junk worksheet and returns us to where we were.
Full Screen Chart:
Dashboards have another problem, and that is, to display many charts on a screen means each chart may be too small to read. This add-in address that too. Click in the plot area, but not on a chart element, and the chart expands to full screen. Click again and it returns to is previous size and position.
Instantiating the Class
Adding drilldown to charts is a simple matter of attaching each chart to a new instance of clsCht. Here is an example of how to do that.
Static oDic As Object 'Scripting Dictionary Object
Dim oCls As clsCht 'Chart Class
Dim oChtObj As ChartObject 'Chart Object
' Use a scripting dictionary to hold class object in memory (note STATIC so it stays in memory)
Set oDic = CreateObject("Scripting.Dictionary")
For Each oChtObj In ActiveSheet.ChartObjects
Set oCls = New clsCht 'Create a new instance of our class
Set oCls.Chart = oChtObj.Chart 'Attach chart to new class instance
Set oDic(oChtObj.Name) = oCls 'Store class instance in data dictionary
Next
That's it! Once attached everything just works. So while there is a bit of code below, once we copy it to our library all we have to do is import this class module and write a bit of code like shown above. Quick! Easy! Simple!
NOTE! For more in the Static statement see: https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/static-statement
Creating the Class - Module Level Code
Our first step is to insert a class module and name it clsCht, then add this module level code.
NOTE! WithEvents tells VBA that one or more declared member variables refer to an instance of a class that can raise events.
See: https://docs.microsoft.com/en-us/dotnet/visual-basic/language-reference/modifiers/withevents
' Version: 11/14/18
' Save As: clsCht
' Description:Expose Embeded Chart Events
' Requisites: Modules modCht
' modGeneral
' Classes clsSettings
' Date Ini Modification
' 06/24/13 CWH Version 2013.05
' 07/10/14 CWH Version 2014.07
' 10/11/14 CWH Modified chart expansion behavior
' 10/22/14 CWH Enabled Single Click Drilldown
' 10/31/14 CWH See Chart_BeforeDoubleClick
' 03/03/16 CWH See Chart_BeforeDoubleClick and GetSeriesPivotRow (Matt G Baish found this issue)
' 10/13/16 CWH Copied Validation to Drilldown
' 10/18/16 CWH Added Worksheet_PivotTableUpdate
' 10/19/16 CWH Added TimeLine
' 10/31/16 CWH Handled protected workbook
' 09/27/17 CWH See Worksheet_PivotTableUpdate
' 09/28/17 CWH Removed frmProgress
' 10/05/17 CWH Allow PivotTables 10 Seconds to refresh
' 01/27/18 CWH Alert user when chart is not a pivot chart
' 02/02/18 CWH Moved PivotTable monitoring to clsKPI
' 03/06/18 CWH See Chart_BeforeDoubleClick
' 09/06/18 CWH Double checked Drilldown calcs
' 11/14/18 CWH Corrected bug when using PowerQuery for Pivot Source
Option Explicit
Const cModule As String = "clsCht"
Public WithEvents Chart As Chart
Public WithEvents Worksheet As Worksheet
Creating the Class - Event Handlers
When the class goes 'out of scope' (when the variable holding the class is set to nothing), the Class_Terminate procedure runs. This performs some house keeping which is considered good practices, but in my experience, is a bit redundant.
Private Sub Class_Terminate()
Set Chart = Nothing
Set Worksheet = Nothing
End Sub
The WithEvents Chart statement in our class module level code enables us to code events like when the mouse button is released while over our chart. When that happens, this procedure uses the Chart's GetChartElement method to tell us the mouse cursor's position (X, Y), the chart element type clicked on (ElementID), and any additional information (Arg1, Arg2).
We are only interested in Arg1 or Arg2 when the element clicked is a chart series (ElementID=xlSeries), in which case, Arg1 = the series' Index and Arg2= the series' point index. With these two values we can determine which cell in the PivotTable hold the value for the chart element and with the PivotTable's cell we can invoke its Show Detail method to reveal supporting data.
We then pretend the chart was double clicked so we can handle single clicks and double clicks identically,
Note! Form more information about the Chart's GetChartElement method see: https://docs.microsoft.com/en-us/office/vba/api/excel.chart.getchartelement
Private Sub Chart_MouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal Y As Long)
Dim ElementID As Long
Dim Arg1 As Long
Dim Arg2 As Long
Chart.GetChartElement X, Y, ElementID, Arg1, Arg2
Chart_BeforeDoubleClick ElementID, Arg1, Arg2, True
End Sub
The WithEvents Chart statement in our class module level code enables us to code events like when the user double clicks anywhere on the chart. This procedure determines what was clicked on and takes the appropriate action such as drilldown, full screen display, restore display, or no action at all.
Private Sub Chart_BeforeDoubleClick(ByVal ElementID As Long, _
ByVal Arg1 As Long, _
ByVal Arg2 As Long, _
Cancel As Boolean)
' Description:Drilldown into PivotChart's data
' Inputs: ElementID Selected Chart Element
' Arg1 When ElementID = xlSeries (3), Series' Value
' Arg2 When ElementID = xlSeries (3), Series' Category
' Cancel Cancel default action flag
' Outputs None
' Requisites Routines Me.Drilldown
' Me.GetSeriesPivotRow
' Notes! msdn.microsoft.com/en-us/library/aa195740(v=office.11).aspx
' Example: *none - This is an event handler
' Date Ini Modification
' 10/04/10 CWH Initial Programming
' 06/24/13 CWH DrillDown Routine
' 10/31/14 CWH Modified Width/Height determination
' 03/03/16 CWH Fixed issue when PivotTable has row groups
' 01/27/18 CWH Alert user when chart is not a pivot chart
' 03/06/18 CWH Restricted Expand/Restore to Plot Area so buttons won't trigger this
' Declarations
Const cRoutine As String = "Chart_BeforeDoubleClick"
Static lTop As Long
Static lLeft As Long
Static lHeight As Long
Static lWidth As Long
Static cTrans As Currency
Dim lRow As Long
Dim oPvt As Object
Dim bScreenUpdating As Boolean
' Error Handling Initialization
On Error GoTo ErrHandler
' Procedure
' Capture Original Dimensions and Positions
If TypeName(Me.Chart.Parent) <> "Workbook" And lTop = 0 Then
cTrans = Me.Chart.ChartArea.Format.Fill.Transparency
If cTrans < 0 Then cTrans = 0
With Me.Chart.Parent
lTop = .TOP: lLeft = .Left
lHeight = .Height: lWidth = .Width
End With
End If
' Drilldown
Select Case ElementID
Case Is = 3, 0 'Series or Data label
lRow = GetSeriesPivotRow(Arg2)
If lRow > 0 Then 'If lRow = 0 this is not a PivotChart
If Arg2 > 0 Then
DrillDown Me.Chart, _
Chart.PivotLayout.PivotTable.DataBodyRange. _
Cells(lRow, Arg1)
End If
End If
Case Is = 19 'Plot Area
' Expand/Restore
If TypeName(Me.Chart.Parent) <> "Workbook" Then
With Me.Chart.Parent
bScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
If .TOP = lTop Then 'Expand
.TOP = ActiveWindow.VisibleRange.TOP
.Left = ActiveWindow.VisibleRange.Left
.Height = ActiveWindow.VisibleRange.Height + _
ActiveWindow.DisplayHorizontalScrollBar
.Width = ActiveWindow.VisibleRange.Width + _
ActiveWindow.DisplayVerticalScrollBar * 30
Me.Chart.ChartArea.Format.Fill.Transparency = 0.05
.Parent.Shapes(Me.Chart.Parent.Name).ZOrder msoBringToFront
Else 'Restore
.TOP = lTop: .Left = lLeft
.Height = lHeight: .Width = lWidth
Me.Chart.ChartArea.Format.Fill.Transparency = cTrans
End If
Application.ScreenUpdating = bScreenUpdating
End With
End If
End Select
Cancel = True
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
The WithEvents Worksheet statement in our class module level code enables us to code events like double clicking on a worksheet. This can happen when someone double clicks on a PivotTable to invoke its "Show Detail" method (Drilldown). While drilldown has always been part of PivotTables, PivotTable drilldown results in the same clutter of junk spreadsheets needing cleanup. So since this class addresses that problem with Pivot Chart drilldown, we decided to address that with PivotTable drilldown as well.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Description:Drilldown into PivotTable data
' Inputs: Target Double Clicked Range
' Cancel Cancel default action
' Outputs None
' Requisites: Routines me.Drilldown
' Example: *none - This is an event handler
' Date Ini Modification
' 10/04/10 CWH Initial Programming
' 06/24/13 CWH DrillDown Routine
' Declarations
Const cRoutine As String = "Worksheet_BeforeDoubleClick"
' Error Handling Initialization
On Error GoTo ErrHandler
' Procedure
If Not Target.PivotTable Is Nothing Then
DrillDown Target, Target
Cancel = True
End If
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Is = 1004: Resume Next 'Not in Pivot
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Creating the Class - Private Functions
This procedure is called by Chart_BeforeDoubleClick(). Its purpose is to determine which PivotTable row contains the Pivot Chart's clicked-on-series. This accounts for subtotal lines in Pivots.
Private Function GetSeriesPivotRow(ByVal Arg2 As Long) As Long
' Description:Determine row within PivotTable
' Inputs: Arg2 When ElementID = xlSeries (3), Series's Category
' Outputs Me PivotTable Row containing series value
' Requisites: *None
' Example: See Chart_BeforeDoubleClick
' Date Ini Modification
' 03/03/16 CWH Initial Programming
' 01/27/18 CWH Alert user when chart is not a pivot chart
' Declarations
Const cRoutine As String = "GetSeriesPivotRow"
Dim oPvt As PivotTable
Dim lMax As Long 'Maximum group levels
Dim n As Long
Dim lRow As Long
' Error Handling Initialization
On Error GoTo ErrHandler
' Initialize Variables
Set oPvt = Chart.PivotLayout.PivotTable
' Procedure
With oPvt.PivotRowAxis
' Pass 1: Determine max group level
For n = 1 To .PivotLines.Count
lMax = WorksheetFunction.Max(lMax, .PivotLines(n).PivotLineCellsFull.Count)
Next
' Pass 2: Determine PivotLine
lRow = 0
For n = 1 To .PivotLines.Count
If .PivotLines(n).PivotLineCellsFull.Count = lMax Then 'This is a detail line
lRow = lRow + 1
If lRow = Arg2 Then
GetSeriesPivotRow = n
Exit For
End If
End If
Next
End With
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Is = 91
Select Case DspErrMsg(cModule & "." & cRoutine, _
"Problem:" & vbTab & "Chart not based on a PivotTable" & vbCr & _
"Fix:" & vbTab & "Add PivotTable over source then build chart over PivotTable")
Case Is = vbAbort: Stop: Resume 'Debug mode
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'Do nothing - end routine
End Select
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
This procedure handles displaying underlying data.
NOTE! For more on MDX see: https://support.microsoft.com/en-us/office/analysis-services-mdx-query-designer-power-pivot-30ab91f9-82a6-4f95-a5ec-2b6b7ab5cbcf
NOTE! for more on the ShowDetail method see: https://docs.microsoft.com/en-us/office/vba/api/excel.pivotitem.showdetail
Private Function DrillDown(oCalledFrom As Object, _
oTarget As Range) As Boolean
' Description:Create Drilldown Worksheet
' Inputs: oCalledFrom Chart or Worksheet that called this routine
' oTarget Cell in PivotTable to show detail
' Outputs: me Success: Success & Populated DrillDown worksheet
' Failure
' Requisites: Function: modGeneral.Exists
' Example: ?DrillDown(me, Range("C4"))
' Date Ini Modification
' 04/07/13 CWH Original programming
' Declarations
Const cRoutine As String = "DrillDown"
Dim oWksDest As Worksheet
Dim oSettings As clsSettings
Dim oWksFrom As Worksheet
Dim oWkb As Workbook
Dim oPvt As PivotTable
Dim sReturnTo As String
Dim lCol As Long
Dim bMDX As Boolean 'MDX vs SourceData Flag
Dim s As String
' Error Handling Initialization
On Error GoTo ErrHandler
Set oSettings = New clsSettings
' Check Inputs and Requisites
Set oPvt = oTarget.PivotTable
If oPvt Is Nothing Then _
Err.Raise DspError, , "Target not in PivotTable"
If InStr(1, "Worksheet,Chart", TypeName(oCalledFrom), vbTextCompare) < 0 Then _
Err.Raise DspError, , "Chart or Worksheet required"
' Initialize Variables
bMDX = True 'Assume this is from a cube
Set oWksFrom = oTarget.Worksheet 'Remember current active worksheet
Set oWkb = oWksFrom.Parent 'Remember current active workbook
' Store active workbook, worksheet, and, if appropriate, cell address in a name object
With ThisWorkbook.Names
If TypeName(oCalledFrom.Parent) = "Workbook" Then
.Add "CalledFrom", oCalledFrom.Name
Else
If Me.Worksheet Is Nothing Then _
.Add "CalledFrom", Me.Chart.Name Else _
.Add "CalledFrom", oTarget.Address(External:=True)
End If
End With
' Procedure
If Not Exists(oWkb.Worksheets, "DrillDown", oWksDest) Then
Set oWksDest = oWkb.Worksheets.Add
oWksDest.Name = "DrillDown"
End If
oWksDest.Cells.Delete
oTarget.ShowDetail = True
Set oWksFrom = Selection.Worksheet
oWksFrom.UsedRange.Cut oWksDest.Cells(5, 1)
Set oSettings = Nothing
With oWksDest
.Activate
Set oSettings = New clsSettings
Application.DisplayAlerts = False
oWksFrom.Delete
Application.DisplayAlerts = True
' Try displaying a cube's data
If oPvt.MDX = vbNullString Then
Range(oPvt.SourceData).Copy
.Cells(5, 1).PasteSpecial xlPasteFormats
.Cells(5, 1).PasteSpecial xlPasteValidation
End If
NoMDX: 'Resume here if an error occurred when attempting to display cube data
' Format
.Cells(6, 2).Select
With ActiveWindow
.FreezePanes = False
.FreezePanes = True
.DisplayGridlines = False
End With
.Cells.EntireColumn.AutoFit
' Title
With oTarget
s = ""
For lCol = 1 To oPvt.RowFields.Count
s = IIf(s <> vbNullString, " and ", "where ")
s = s & oPvt.RowFields(1)
s = s & " = "
s = s & Intersect(.EntireRow, oPvt.RowRange.Columns(lCol))
Next
If Not bMDX Then _
s = "Displaying " & .PivotField.Name & " From table " & s Else _
s = "Displaying " & .PivotField.Name & " From " & _
oPvt.SourceData & " table " & s
ActiveSheet.Cells(1) = s
End With
With .Cells(1, 1)
.UnMerge: .Style = "Title": .Resize(1, 20).Merge
End With
' Return Button
CrtRtnBtn oWksDest, "'" & ThisWorkbook.Name & "'!modCht.DltWks"
End With
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Is = 1004:
If bMDX Then bMDX = Not bMDX: Resume NoMDX
'Double click outside Pivottable - ignore
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
' Clean Up
If Not oWksDest Is Nothing Then oWksDest.Activate
End Function
This procedure addresses two concerns. The first is providing an easy way for users to get back to where they were when they made a drilldown request by providing a "Back Button". The second is cleaning up the newly created worksheet containing detail data when it is not longer being needed by attaching to the back button a routine that removes the worksheet.
Private Function CrtRtnBtn(oWorksheet As Worksheet, _
sDestination As String) As Boolean
' Description:Create Return Button
' Inputs: oWorksheet Button's Worksheet
' sDestination Button's Destination
' Outputs: me Success/Failure
' Requisites: *None
' Example: CrtRtnBtn oWksDest, "'" & oWksDest.Parent.Name & "'!modCht.DltWks"
' Date Ini Modification
' 10/11/14 CWH Original programming
' Declarations
Const cRoutine As String = "CrtRtnBtn"
Dim oShape As Shape
' Error Handling Initialization
On Error GoTo ErrHandler
CrtRtnBtn = Failure
' Procedure
With oWorksheet.Shapes.AddShape(msoShapeOval, 10, [A2].TOP, 35, 35)
.ShapeStyle = msoShapeStylePreset39
.Name = "Button"
With oWorksheet.Shapes.AddShape(Type:=msoShapeLeftArrow, _
Left:=.Left + 2, _
TOP:=.TOP + .Height / 2 - .Height * 0.75 / 2, _
Width:=.Width - 6, _
Height:=.Height * 0.75)
.ShapeStyle = msoShapeStylePreset7
.Name = "Arrow"
End With
End With
With oWorksheet.Shapes.Range(Array("Button", "Arrow")).Group
.Name = "Return"
.OnAction = sDestination
End With
CrtRtnBtn = Success
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Module Code
Unfortunately, we cannot do everything in the class module. This routine must be placed in a normal module. It is responsible for deleting the worksheet when the user clicks the back button on the drilldown worksheet.
Public Function DltWks(Optional oWks As Object) As Boolean
' Description:Delete Worksheet
' Inputs: vWorksheet Worksheet to Delete
' Outputs: Me Success/Failure
' Requisites: Routines *None
' Example: ?DltWks()
' Date Ini Modification
' 10/31/14 CWH Initial Programming
' Declarations
Const cRoutine As String = "DltWks"
' Error Handling Initialization
On Error GoTo ErrHandler
DltWks = Failure
' Check Inputs and Requisites
If oWks is Nothing Then Set oWks = ActiveSheet
' Procedure
Application.DisplayAlerts = False
oWks.Delete
Application.DisplayAlerts = True
DltWks = Success
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function