VBA 显示数据透视表中所有行的行总计单元格的详细信息，并将工作表重命名为行标签字段

Question

我试图显示每一行的详细信息（除了空白行和总计行）并将工作表重命名为行标签，而无需双击每行总计，因为普通表有数百行。

数据透视表的精简示例

如有任何帮助，我们将不胜感激。

我已尝试下面的编码，但它返回列 2023/001 的详细信息，我想知道我需要进行哪些更改，以便它将在最右侧显示总计列的详细信息，每个月都是添加的位置可变

Sub ShowDrillDownByRow()
    --creates separate drilldown sheet for each
     row in the first pivotTable of the active sheet

     attempts to rename new sheets with rowitem name
    if there is only one rowfield.

    Dim bDrillDownMode As Boolean
    Dim lNRowsToDrill As Long
    Dim pvt As PivotTable
    Dim rCell As Range, rActiveCell As Range
    Dim sActiveSheetName As String

    On Error Resume Next
    Set pvt = ActiveSheet.PivotTables(1)
    If Err.Number <> 0 Then
    MsgBox "No PivotTable found on Active Sheet"
    Exit Sub
    End If
    On Error GoTo 0

    '--save to reset before exit
    Set rActiveCell = ActiveCell

    Application.ScreenUpdating = False

    With pvt
    '--drill down must be enabled
    bDrillDownMode = .EnableDrilldown
    .EnableDrilldown = True

    With .DataBodyRange
    '--don't drill down grand total row
    lNRowsToDrill = .Rows.Count + pvt.ColumnGrand

    For Each rCell In .Resize(lNRowsToDrill, 1)
    rCell.ShowDetail = True
    '--rename new sheets if only one rowfield
    ' could be modified to handle more rowfields
    If pvt.RowFields.Count = 1 Then
    '--err handler in case of invalid sheet name
    ' or sheetname already in use
    On Error Resume Next
    ActiveSheet.Name = rCell.PivotCell.RowItems(1)
    On Error GoTo 0
    End If
    Next rCell
    End With
    End With

    ExitProc:
    pvt.EnableDrilldown = bDrillDownMode
    Application.Goto rActiveCell
    Application.ScreenUpdating = True

End Sub

Answer 1

• 您的代码即将完成。迭代范围应更改如下。

    For Each rCell In .Columns(.Columns.Count).Resize(lNRowsToDrill, 1).Cells
        rCell.ShowDetail = True
        '--rename new sheets if only one rowfield
        ' could be modified to handle more rowfields
        If pvt.RowFields.Count = 1 Then
            '--err handler in case of invalid sheet name
            ' or sheetname already in use
            On Error Resume Next
            ActiveSheet.Name = rCell.PivotCell.RowItems(1)
            On Error GoTo 0
        End If
    Next rCell