excelvbapivot

VBA to show detail of row total cell for all rows in pivot table and rename sheets to the row label field

I am trying to show the detail on each of these rows (except the blank and grand total row) & rename the sheet to the row label without double clicking each row total as the normal table has hundreds of rows.

Condensed example of pivot table

1

Any help would be appreciated.

I have tried the coding below but it returns the details of column 2023/001, I would like to know what changes I need to make so it will show the detail of the grand total column on the far right, which as each month is added is in a variable position

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
Solution 
  •     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