VBA Show detail pivot table row

[AndreaJ]

Hi

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 as the tables can have hundreds of rows.

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

Any help would be appreciated