I saw lots of articles for implementing drillthrough. I have taken the
best bits of all and modified them to work for multi partition cube.
This works for most of the times.. Simply add this to bas file.

Option Explicit

Private lasterr As Integer
Private pfcombo() As Integer
Private pfarray() As Integer
Private row As Integer
Private col As Integer
Private pfdim As Integer

Private dduct As Boolean

Private dtStart As Date


Const WAITSTRING As String = "Retreiving detail data..."
Const MAXROWS As Integer = 0
Const TIMEOUT As Integer = 60 * 5 '5 minutes

'App specific constants
Const APPNAME As String = "Reporting"
Const wsName As String = "Drillthough"

Sub Drillthrough()

' History
' Modified by Arun NS : To work with cube having multiple
partitions.
' Also works for cubes that return data with duplicate column name
in recordset.
'
' Page field logic : Simon C.H. Ng @ Mar,28-2003. email:
simonchng (AT) mesiniga (DOT) com.my
' Source :
http://msdn.microsoft.com/library/de...extendolap.asp

Dim conn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rs As ADODB.Recordset

Dim pcell As PivotCell
Dim pt As PivotTable
Dim pf As PivotField
Dim ws As Worksheet

Dim qry As String
Dim msgstr As String
Dim mbrname As String
Dim drill_qry As String

Dim n As Integer, m As Integer
Dim loopmax As Integer
Dim axisn As Integer
Dim i As Integer

Dim rsinit As Boolean
Dim fldval As Variant

dtStart = Now
On Error GoTo errmsg


Set pcell = ActiveCell.PivotCell

On Error GoTo 0
If Not (pcell.PivotTable.PivotCache.OLAP) Then GoTo errmsg
If pcell.PivotCellType <> xlPivotCellValue Then GoTo errmsg

Set pt = pcell.PivotTable

If Not pt.PivotCache.IsConnected Then pt.PivotCache.MakeConnection

Set conn = pt.PivotCache.ADOConnection
conn.CommandTimeout = 0
Set cmd.ActiveConnection = conn
conn.CommandTimeout = TIMEOUT

'identify how many dimensions in the PageField
pfdim = pt.PageFields.Count
loopmax = 1

'This section only applicable when there are dimensions in the
pagefield area
If pfdim > 0 Then
'create an array to hold the values for (PageField index,
number of selected members, balance counter)
ReDim pfarray(pfdim - 1, 2)

'Find out how members are selected in each pagefield Dimension
lasterr = 0
For n = 0 To (pfdim - 1)
m = 1
Set pf = pt.PageFields(n + 1)
If pf.DataRange = "(Multiple Items)" Then
On Error GoTo pferr
Do While True
mbrname = pf.CurrentPageList(m)
If lasterr = 9 Then
lasterr = 0
Exit Do
End If
m = m + 1
Loop
On Error GoTo 0

pfarray(n, 0) = n + 1
pfarray(n, 1) = m - 1
pfarray(n, 2) = m - 1
Else
If Left(pf.DataRange, 3) = "All" Then
pfarray(n, 0) = n + 1

'Assign a value of 0 here to signify that this
dimension
'is set to the ALL level
pfarray(n, 1) = 0
pfarray(n, 2) = 0
Else
pfarray(n, 0) = n + 1

'All others where only one member is selected
assign a value of one
pfarray(n, 1) = 1
pfarray(n, 2) = 1
End If
End If

Next

'Calculate how many times to loop and store it to loopmax
For n = 0 To (pfdim - 1)
If pfarray(n, 1) <> 0 Then
loopmax = loopmax * pfarray(n, 1)
End If
Next

'Create an array to hold the index combinations of the selected
members in the pagefield
ReDim pfcombo(loopmax - 1, pfdim - 1)
For row = 1 To loopmax
col = 1
MakeCombo col
Next
End If

rsinit = True

'Begin the loop here
For n = 1 To loopmax
axisn = 0
drill_qry = "Drillthrough maxrows " & CStr(MAXROWS) & " Select
"

'Include row coordinates in drillthrough query
For i = 1 To pcell.RowItems.Count - 1
If pcell.RowItems(i).Parent.CubeField.Name <>
pcell.RowItems(i + 1).Parent.CubeField.Name Then
drill_qry = drill_qry & "{" & pcell.RowItems(i) & "} on
" & axisn & ", "
axisn = axisn + 1
End If
Next i
If pcell.RowItems.Count > 0 Then
drill_qry = drill_qry & "{" & pcell.RowItems(i) & "} on " &
axisn & ", "
axisn = axisn + 1
End If

'include column coordinates in drillthrough query
For i = 1 To pcell.ColumnItems.Count - 1
If pcell.ColumnItems(i).Parent.CubeField.Name <>
pcell.ColumnItems(i + 1).Parent.CubeField.Name Then
drill_qry = drill_qry & "{" & pcell.RowItems(i) & "} on
" & axisn & ", "
axisn = axisn + 1
End If
Next i
If pcell.ColumnItems.Count > 0 Then
drill_qry = drill_qry & "{" & pcell.ColumnItems(i) & "} on
" & axisn & ", "
axisn = axisn + 1
End If

'include page fields in drillthrough query
If pfdim > 0 Then
For i = 1 To pfdim
Set pf = pt.PageFields(i)
If pfarray(i - 1, 1) = 1 Then
'This part is used for those dimensions in the
pagefield that has only one memberSelected
On Error Resume Next
drill_qry = drill_qry & "{" &
pt.PageFields(i).CurrentPageName & "} on " & axisn & ", "
If Err.Number = 1004 Then
drill_qry = drill_qry & "{" &
pf.CurrentPageList(pfcombo(n - 1, i - 1)) & "} on " & axisn & ", "
End If
axisn = axisn + 1
Else
'This part is used for thosedimensions in the
pagefield that has more than member Selected
'Note that dimensions placed in the pagefield that
is set at the all level is ignored.
If pfcombo(n - 1, i - 1) > 0 Then
drill_qry = drill_qry & "{" &
pf.CurrentPageList(pfcombo(n - 1, i - 1)) & "} on " & axisn & ", "
axisn = axisn + 1
End If
End If
Next
End If

drill_qry = Left$(drill_qry, Len(drill_qry) - 2)
drill_qry = drill_qry & " From " & "[" &
pt.PivotCache.CommandText & "]"

On Error GoTo errmsg

DoEvents

Set rs = conn.Execute(drill_qry)
' Set rs = New ADODB.Recordset
' rs.Source = drill_qry
' Set rs.ActiveConnection = conn
' rs.Open

If rsinit Then
'add a new worksheet and give appropriate name
Set ws = Worksheets.Add
ws.Name = GetWorkSheetName(wsName)
rsinit = False
End If

If Not RecordSetToExcel(rs, ws) Then GoTo ExitSub

On Error GoTo 0

Next


MsgBox "DrillThrough complete." & vbCrLf & "Time taken (in min) : "
& DateDiff("n", dtStart, Now), vbInformation, APPNAME
Exit Sub

pferr:
lasterr = Err.Number
Resume Next

'Various conditions give generic error message
errmsg:
MsgBox "Error occured when attempting to drillthrough !" & vbCrLf &
vbCrLf & _
"Details : " & vbCrLf & Err.Description & vbCrLf & "Source
: " & Err.Source & vbCrLf & "Number : " & Err.Number & vbCrLf & "Time
taken (in min) : " & DateDiff("n", dtStart, Now), vbCritical, APPNAME

ExitSub:
End Sub


Sub MakeCombo(col)
'************************************************* ************
'* Coded by Simon C.H. Ng @ Mar,28-2003
'* email: simonchng (AT) mesiniga (DOT) com.my
'************************************************* ************

'This subroutine is used to handle dynamic recursive looping
'for an unknown number of dimensions placed which is only
ascertained at runtime

'assign the combo array with the last column in the pfarray
'Note, pfarray(n,2) is used to store the number signifying the
remaining numbers not used in the combo
pfcombo(row - 1, col - 1) = pfarray(col - 1, 2)

'after assigning the value to the combo for the current row, move
on to the next column
col = col + 1
If col <= pfdim Then
'Recurse for the next column
MakeCombo (col)
End If

'rollback to the previous column
col = col - 1

If col > 0 Then
If col = pfdim Then
'If the last column in the combo array, check the value of
the 3rd
'column in pfarray. 3 possible combination of values can
arise here i.e.
'0,1 or more than 1. If it is 0, do nothing but set the
variable dduct to
'true. The variable dduct is used to tell the next col-1 to
reduce the value
'in the 3rd column of pfcombo by 1.
Select Case pfarray(col - 1, 2)
Case 0
dduct = True
Case 1
dduct = True
pfarray(col - 1, 2) = pfarray(col - 1, 1)
Case Else
pfarray(col - 1, 2) = pfarray(col - 1, 2) - 1
dduct = False
End Select
Else
If dduct Then
Select Case pfarray(col - 1, 2)
Case 0
dduct = True
Case 1
dduct = True
pfarray(col - 1, 2) = pfarray(col - 1, 1)
Case Else
pfarray(col - 1, 2) = pfarray(col - 1, 2) - 1
dduct = False
End Select
End If
End If

End If

End Sub

Private Function RecordSetToExcel(rs As Recordset, ws As Worksheet) As
Boolean
Dim recArray As Variant
Dim fldCount As Integer
Dim recCount As Integer

On Error GoTo Err_Handler

Do While Not (rs Is Nothing)
If ws.UsedRange.Rows.Count = 1 And ws.Cells(1, 1) = "" Then
PopulateHeaders rs, ws
If Val(Mid(Application.Version, 1, InStr(1,
Application.Version, ".") - 1)) > 8 Then
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).CopyFromRecordset
rs
Else
recArray = rs.GetRows
recCount = UBound(recArray, 2) + 1
fldCount = rs.Fields.Count
ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Resize(recCount,
fldCount).Value = TransposeDim(recArray)
End If

Set rs = rs.NextRecordset
Loop
RecordSetToExcel = True

Exit Function
Err_Handler:

MsgBox "Error occured when attempting to drillthrough !" & vbCrLf &
vbCrLf & _
"Details : " & vbCrLf & Err.Description & vbCrLf & "Source
: " & Err.Source & vbCrLf & "Number : " & Err.Number & vbCrLf & "Time
taken (in min) : " & DateDiff("n", dtStart, Now), vbCritical, APPNAME

RecordSetToExcel = False
End Function

Private Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant

Xupper = UBound(v, 2)
Yupper = UBound(v, 1)

ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = Format$(v(Y, X))
Next Y
Next X

TransposeDim = tempArray

End Function

Private Sub PopulateHeaders(rs As Recordset, ws As Worksheet)
Dim fld As ADODB.Field
Dim iCol As Integer

iCol = 1
For Each fld In rs.Fields
ws.Cells(1, iCol) = fld.Name
iCol = iCol + 1
Next

End Sub

Private Function GetWorkSheetName(ParentName As String) As String
Dim wst As Worksheet
Dim cnt As Integer
Dim wsName As String
Dim bSearch As Boolean

cnt = 0

bSearch = True
Do While bSearch
cnt = cnt + 1
wsName = ParentName & "_" & cnt

For Each wst In Worksheets
If wst.Name = wsName Then
bSearch = True
Exit For
End If
bSearch = False
Next
Loop

GetWorkSheetName = wsName

End Function