DrillThrough in Excel 2000

Hi all
I needed to provide OLAP drillthough for users with Excel 2000. There
are numerous threads on this topic - but no-one seems to have produced
the definitive work around.
So I made one myself and here it is. I based it on the extending OLAP
solution originally published on MSDN. It works most of the time, and
assumes that dimension members are not duplicated across levels.
Use this as a standalone workbook, an add-in or in a report workbook.
Paste this code into the code area of ThisWorkbook.
Add references to ADO and ADOMD.
I hope someone finds it useful.
Ian Bamforth
-- the code --
' This VBA macro is a modified version of an MSDN sample. The sample
was contained
' in an article titled "Extending Excel OLAP Functionality"
'
' Russ Whitney
' ProClarity Corporation
' August 15, 2003
'
'Minor Tweak IPB Sept 04 to work as standalone
'
'Rewite for Excel 2000 ipb March 20 2005 (removed PivotCell and
ADOconnection objects)
' Runs when the workbook is opened
Private Sub Workbook_Open()
Dim oPTCmdBar As CommandBar
Dim oPTCmdBarCntrl As CommandBarControl
Dim oPTDrillCmd As CommandBarControl
' Get a reference to the PivotTable's context menu
Set oPTCmdBar = Application.CommandBars("PivotTable context menu")
Set oPTDrillCmd = Nothing
' Check all the items in the context menu to see if we already
added our item
For Each oPTCmdBarCntrl In oPTCmdBar.Controls
If oPTCmdBarCntrl.Caption = "Drill to details2k" Then
Set oPTDrillCmd = oPTCmdBarCntrl
Exit For
End If
Next oPTCmdBarCntrl
' If our drill menu option was not already in the context menu then
add it
If oPTDrillCmd Is Nothing Then
Set oPTDrillCmd =
oPTCmdBar.Controls.Add(Type:=msoControlButton, temporary:=True)
oPTDrillCmd.Caption = "Drill to details2k"
End If
' Regardless of whether the item was on the menu or not, make sure
it runs the
' Drillthrough routine when it is selected
oPTDrillCmd.OnAction = "ThisWorkbook.Drillthrough2k"
End Sub
Private Function CreateDrillMdx2k(oCell As Range) As String
Dim sDrillMdx As String
Dim i As Integer
Dim iAxisNum As Integer
Dim iRowCol As Integer
Dim Mrow As Range, Mcol As Range
Dim McolLabel As String, MrowLabel As String
' The start of the query
sDrillMdx = "DRILLTHROUGH MAXROWS 1000 SELECT "
' Determine the dimension members on the row and column headers
matching this cell
'...take the row label adjacent to the data area
Set Mrow = Cells(oCell.Row, oCell.PivotTable.DataBodyRange.Column -
1)
'... and pick from the previous column if it is empty (ie the item
was drilled down) - allow up to 4 levels
For i = 0 To 3
McolLabel = Mrow.Offset(0, -i)
If McolLabel <> "" Then Exit For
Next
'...remove the word Total from the end of the label
If Right(McolLabel, 6) = " Total" Then McolLabel = Left(McolLabel,
Len(McolLabel) - 6)
'...repeat for the column label
Set Mcol = Cells(oCell.PivotTable.DataBodyRange.Row - 1,
oCell.Column)
For i = 0 To 3
MrowLabel = Mcol.Offset(-i, 0)
If MrowLabel <> "" Then Exit For
Next
If Right(MrowLabel, 6) = " Total" Then MrowLabel = Left(MrowLabel,
Len(MrowLabel) - 6)
'assume that the row and column labels are unique members of
dimensions
sDrillMdx = sDrillMdx & "{[" & MrowLabel & "]} ON " & 0 & ", "
sDrillMdx = sDrillMdx & "{[" & McolLabel & "]} ON " & 1 & ", "
iAxisNum = 2
Dim oPT As PivotTable
Dim pf As PivotField
Set oPT = oCell.PivotTable
'Set oPageFields = oPT.PageFields
' Add the member names for any paged dimensions
For Each pf In oPT.PageFields
sDrillMdx = sDrillMdx & "{" & pf.CurrentPageName & "} ON " &
iAxisNum & ", "
iAxisNum = iAxisNum + 1
Next
' Trim off the extra comma left by the last item appended to the
query
sDrillMdx = Left$(sDrillMdx, Len(sDrillMdx) - 2)
' Now add the cube name in the FROM clause
sDrillMdx = sDrillMdx & " FROM [" & oPT.PivotCache.CommandText &
"]"
' Return the MDX statement
CreateDrillMdx2k = sDrillMdx
End Function
Public Sub Drillthrough2k()
On Error GoTo errh
Dim oCell As Range
Dim opTItem As PivotItem
Dim oPT As PivotTable
Dim oOlapConn As New ADODB.Connection
Dim sDrillMdx As String
Dim oRecordSet As New ADODB.Recordset
Dim oSheet As Worksheet
Dim oQueryTable As QueryTable
Dim Mdrill As Boolean
Set oCell = ActiveCell
If WorksheetFunction.IsText(oCell) Then MsgBox "You should choose a
number that you wish to drillThrough": Exit Sub
Set oPT = oCell.PivotTable
'Set oOlapConn = oPT.PivotCache.ADOConnection
'NOT available in Excel 2K so we create new
'resolve ADO connection string by removing "OLAP;" from pivot cache
connection
oOlapConn.ConnectionString = Mid(oPT.PivotCache.Connection, 7, 150)
' Create the MDX Drillthrough statement
sDrillMdx = CreateDrillMdx2k(oCell)
oOlapConn.Open
' Execute the Drillthrough statement to get a recordset
oRecordSet.Source = sDrillMdx
oRecordSet.ActiveConnection = oOlapConn
oRecordSet.Open
' Create a new worksheet and add the drillthrough results
For Each oSheet In ActiveWorkbook.Sheets
If oSheet.Name = "DrillThrough" Then
Mdrill = True
oSheet.Activate
Cells(ActiveCell.SpecialCells(xlLastCell).Row + 2, 1).Activate
Exit For
End If
Next
If Not (Mdrill) Then
Set oSheet = ActiveWorkbook.Sheets.Add
oSheet.Name = "DrillThrough"
End If
ActiveCell = sDrillMdx
Set oQueryTable = oSheet.QueryTables.Add(oRecordSet,
ActiveCell.Cells(2, 1))
oQueryTable.Refresh
Exit Sub
errh:
MsgBox Error, vbInformation
End SubIan,
Thanks! Works well.
I have a question that will show my ignorance of cubes. Does doing a
"drillthrough" take you to the details stored in the cube, or does it
take you all the way back to the data warehouse?
TIA
JOHolloway
bammers99 wrote:
> Hi all
> I needed to provide OLAP drillthough for users with Excel 2000.
There
> are numerous threads on this topic - but no-one seems to have
produced
> the definitive work around.
> So I made one myself and here it is. I based it on the extending
OLAP
> solution originally published on MSDN. It works most of the time,
and
> assumes that dimension members are not duplicated across levels.
> Use this as a standalone workbook, an add-in or in a report workbook.
> Paste this code into the code area of ThisWorkbook.
> Add references to ADO and ADOMD.
> I hope someone finds it useful.
> Ian Bamforth|||Hi John
All the way back to the warehouse ...
- without needing to grant users logon rights to the SQL database
- In the Analysis Manager dialog, you can see all the columns in the
tables participating in the cube - and add others! You are not simply
resticted to fields assigned to measures and dimensions
misterholloway@.yahoo.com wrote:[vbcol=seagreen]
> Ian,
> Thanks! Works well.
> I have a question that will show my ignorance of cubes. Does doing a
> "drillthrough" take you to the details stored in the cube, or does it
> take you all the way back to the data warehouse?
> TIA
>
> JOHolloway
>
> bammers99 wrote:
> There
> produced
> OLAP
> and
workbook.[vbcol=seagreen]|||Ok John:
But you need to define the drill-throught query and options in the Analysis
Services... no?
Thanks
Rodrigo
"bammers99" wrote:

> Hi John
> All the way back to the warehouse ...
> - without needing to grant users logon rights to the SQL database
> - In the Analysis Manager dialog, you can see all the columns in the
> tables participating in the cube - and add others! You are not simply
> resticted to fields assigned to measures and dimensions
>
> misterholloway@.yahoo.com wrote:
> workbook.
>