![如何在 Excel 数据透视表深入钻取中过滤源工作表?](https://linux22.com/image/1320257/%E5%A6%82%E4%BD%95%E5%9C%A8%20Excel%20%E6%95%B0%E6%8D%AE%E9%80%8F%E8%A7%86%E8%A1%A8%E6%B7%B1%E5%85%A5%E9%92%BB%E5%8F%96%E4%B8%AD%E8%BF%87%E6%BB%A4%E6%BA%90%E5%B7%A5%E4%BD%9C%E8%A1%A8%EF%BC%9F.png)
我在 Excel 电子表格中记录我的开支。在第二个工作表中,我有一个数据透视表,可以按月份和类别分组我的开支以查看总数。如果我双击某个单元格,就会自动添加一个新工作表,其中显示所选月份/类别的开支列表。这非常棒,但新工作表包含开支的副本,因此我无法更新它们。此外,每次深入研究时,我都必须不断删除这些工作表,这非常烦人。
我找到了一个示例,解释了如何自动重命名和删除添加的工作表:http://www.contextures.com/excel-pivot-table-drilldown.html
我真正想要的是切换回第一张表并相应地更新过滤器。有人知道我该如何实现吗?
非常感谢,
帕特里克
答案1
不太简单。我重建了代码每日剂量的 Excel充分利用 Excel 2010 更好的过滤选项。如果您在数据透视表中选择一个数据点并运行宏,它将为您提供源数据中的匹配行。它通过使用“显示详细信息”功能,然后为每列创建一个过滤器以匹配数据来实现这一点。
您可以在新的右键单击按钮上进行设置,或者覆盖默认的显示详细信息行为。
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