Não é extremamente simples. Reformulei o código de
Você pode configurá-lo em um novo botão de clique ou sobrescrever o comportamento padrão de detalhes da exibição.
Private mPivotTable As PivotTable
Sub GetDetailsOnSource()
'turn off updates to speed up code execution
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
Set mPivotTable = Selection.PivotTable
On Error GoTo 0
If Not mPivotTable Is Nothing Then
If mPivotTable.PivotCache.SourceType <> xlDatabase Or _
Intersect(Selection, mPivotTable.DataBodyRange) Is Nothing Then
Set mPivotTable = Nothing
End If
End If
Selection.ShowDetail = True
GetDetailInfo
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub GetDetailInfo()
Dim rCell As Range
Dim rData As Range
Dim vMin As Variant, vMax As Variant
Dim rSource As Range
Dim lOldCalc As Long, sh As Worksheet
Dim colItems As Collection, arrFilter As Variant, lLoop As Long, lLastRow As Long
Dim bBlanks As Boolean, bNumbers As Boolean, sNumberFormat As String
Set sh = ActiveSheet
If Not mPivotTable Is Nothing Then
lOldCalc = Application.Calculation
Application.Calculation = xlCalculationManual
Set rSource = Application.Evaluate(Application.ConvertFormula(mPivotTable.SourceData, xlR1C1, xlA1))
rSource.Parent.AutoFilterMode = False
rSource.AutoFilter
lLastRow = sh.ListObjects(1).Range.Rows.Count
sh.ListObjects(1).Unlist
'Loop through the header row
For Each rCell In Intersect(sh.UsedRange, sh.Rows(1)).Cells
If Not IsDataField(rCell) Then
If Application.WorksheetFunction.CountIf(rCell.Resize(lLastRow), "") > 0 Then bBlanks = True Else bBlanks = False
rCell.Resize(lLastRow).RemoveDuplicates Columns:=1, Header:=xlYes
If Application.WorksheetFunction.CountA(rCell.EntireColumn) = Application.WorksheetFunction.Count(rCell.EntireColumn) + 1 _
And Not IsDate(sh.Cells(Rows.Count, rCell.Column).End(xlUp)) Then 'convert numbers to text
bNumbers = True
rCell.EntireColumn.NumberFormat = "0"
rCell.EntireColumn.TextToColumns Destination:=rCell, DataType:=xlFixedWidth, _
OtherChar:="" & Chr(10) & "", FieldInfo:=Array(0, 2), TrailingMinusNumbers:=True
Else
bNumbers = False
End If
arrFilter = sh.Range(rCell.Offset(1), sh.Cells(sh.Rows.Count, rCell.Column).End(xlUp).Offset(IIf(bBlanks, 1, 0))).Value
If Application.WorksheetFunction.Subtotal(3, rCell.EntireColumn) = 1 Then
rSource.AutoFilter Field:=rCell.Column, Criteria1:=""
Else:
arrFilter = Application.Transpose(arrFilter)
sNumberFormat = rSource.Cells(2, rCell.Column).NumberFormat
If bNumbers Then _
rSource.Columns(rCell.Column).NumberFormat = "0"
rSource.AutoFilter Field:=rCell.Column, Criteria1:=arrFilter, Operator:=xlFilterValues
rSource.Cells(2, rCell.Column).NumberFormat = sNumberFormat
End If
Set arrFilter = Nothing
End If
Next rCell
'so it doesn’t run at next sheet activate
Set mPivotTable = Nothing
Application.Calculation = lOldCalc
'Delete the sheet created by double click
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
rSource.Parent.Activate
End If
End Sub
Private Function IsDataField(rCell As Range) As Boolean
Dim bDataField As Boolean
Dim i As Long
bDataField = False
For i = 1 To mPivotTable.DataFields.Count
If rCell.Value = mPivotTable.DataFields(i).SourceName Then
bDataField = True
Exit For
End If
Next i
IsDataField = bDataField
End Function