VBA实现PivotTable Grand Total钻取数据输出至指定工作表咨询

核心原理 #

• 透视表总计项双击钻取的本质是操作总计单元格的ShowDetail属性，将该属性设为True即可自动生成对应筛选条件下的全量明细，不需要模拟鼠标双击操作
• 每次钻取会自动新建一个临时工作表存放明细，只需将临时表内容复制到指定目标工作表后删除临时表即可，不需要手动指定明细输出位置
• 字段筛选直接操作透视表字段的PivotItems可见性即可，稳定性远高于宏录制的界面操作代码

原有代码问题修正 #

原有透视表创建代码存在重复调用CreatePivotTable的问题，会导致透视表重复生成报错，修正后的基础创建逻辑如下：

' 先声明所有变量，避免隐式声明报错
Dim DSheet As Worksheet, PSheet As Worksheet
Dim LastRow As Long, LastCol As Long
Dim PRange As Range
Dim PCache As PivotCache
Dim PTable As PivotTable

' 给工作表变量赋值，按需修改表名
Set DSheet = ThisWorkbook.Worksheets("数据源表名") ' 替换为实际的数据源工作表名
Set PSheet = ThisWorkbook.Worksheets("D_S")

PSheet.Activate
On Error Resume Next
PSheet.PivotTables("D/S").TableRange2.Clear
On Error GoTo 0 ' 及时关闭错误忽略，避免后续错误被吞

LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)

' 创建透视缓存
Set PCache = ActiveWorkbook.PivotCaches.Create( _
    SourceType:=xlDatabase, _
    SourceData:=PRange)

' 只创建一次透视表，删除原代码里重复创建的部分
Set PTable = PCache.CreatePivotTable( _
    TableDestination:=PSheet.Cells(2, 2), _
    TableName:="D/S")

' 配置透视表字段
With PTable.PivotFields("DesktopType")
    .Orientation = xlRowField
    .Position = 1
End With
PTable.AddDataField PTable.PivotFields("email"), "Count of email", xlCount

自动筛选+钻取功能实现代码 #

在上述透视表创建逻辑后追加以下代码即可实现需求，注意替换代码里标注的DesktopType实际筛选值：

Dim targetSht As Worksheet
Dim tempSht As Worksheet
Dim gtCell As Range
Dim ptItem As PivotItem

' 定位透视表的Grand Total单元格，即数据区域右下角的总计单元格
Set gtCell = PTable.GetPivotData(PTable.DataFields(1).Name).Offset(1, 1)

' --------------------------
' 处理D类值的筛选与钻取
' --------------------------
' 清空D表现有内容
Set targetSht = ThisWorkbook.Worksheets("D")
targetSht.Cells.Clear
' 筛选DesktopType字段，把"D类实际值"替换成要筛选的对应值，比如"D"
With PTable.PivotFields("DesktopType")
    For Each ptItem In .PivotItems
        ptItem.Visible = (ptItem.Name = "D类实际值")
    Next
End With
' 触发钻取，生成临时明细工作表
gtCell.ShowDetail = True
Set tempSht = ActiveSheet
' 复制明细到D表
tempSht.UsedRange.Copy targetSht.Cells(1, 1)
' 删除临时表
Application.DisplayAlerts = False
tempSht.Delete
Application.DisplayAlerts = True

' --------------------------
' 处理S类值的筛选与钻取
' --------------------------
' 回到透视表所在工作表
PSheet.Activate
' 清空S表现有内容
Set targetSht = ThisWorkbook.Worksheets("S")
targetSht.Cells.Clear
' 筛选DesktopType字段，把"S类实际值"替换成要筛选的对应值，比如"S"
With PTable.PivotFields("DesktopType")
    For Each ptItem In .PivotItems
        ptItem.Visible = (ptItem.Name = "S类实际值")
    Next
End With
' 触发钻取
gtCell.ShowDetail = True
Set tempSht = ActiveSheet
' 复制明细到S表
tempSht.UsedRange.Copy targetSht.Cells(1, 1)
' 删除临时表
Application.DisplayAlerts = False
tempSht.Delete
Application.DisplayAlerts = True

注意事项 #

• 代码运行前请确认工作簿里已经存在名为D和S的两个工作表，不存在可手动先新建
• 如果DesktopType字段下D/S对应多个筛选值，修改筛选判断逻辑即可，比如要同时显示值为"D1"、"D2"的项，就把判断条件改成ptItem.Visible = (ptItem.Name = "D1" Or ptItem.Name = "D2")
• 不要在透视表创建后随意插入/删除行列，避免总计单元格定位偏移，如果透视表结构调整，可以手动重新指定gtCell为要钻取的总计单元格

内容的提问来源于stack exchange，提问作者ranv