VBA to manually position an Excel pivot when AutoSort is blocked

As you might know, "AutoSort and AutoShow can't be used with custom calculations that use positional references", such as % Difference From of (previous).

But Excel doesn't mind if you manually position rows any way you want. It can be done manually by dragging and dropping, or with VBA via PivotFields(...).PivotItems(...).position = X. The questions is how to do it automatically in VBA by Number descending like in the second screenshot?

If the row data is:

Then a pivot of Parent-Child-Number-% Difference From looks like:

If I manually position it by Number (by dragging), then it looks similar to how I want:

I've managed to automatically position by Parent but not by Child, code below (just run ManualSortPivotNow).

I think the only problem is fieldArgs(2 * j) = Chr(34) & pvt.RowFields(j).PivotItems(pvtItem.Position).Name & Chr(34) because it only works correctly on Parent. I left some msgbox to help debugging.

Sub ManualSortPivotNow()
    Call ManualSortPivot
End Sub

Sub ManualSortPivot(Optional pvt As PivotTable)
    On Error GoTo Cleanup ' Ensure events are re-enabled on error
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    If pvt Is Nothing Then
        On Error Resume Next
        Set pvt = ActiveSheet.PivotTables(1)
        If pvt Is Nothing Then
            MsgBox "No PivotTable provided and no PivotTables found on the ActiveSheet.", vbExclamation
            GoTo Cleanup
        End If
        On Error GoTo Cleanup
    End If
    
    Dim pvtField As PivotField
    
    pvt.ManualUpdate = True
    
    ' Loop through all the row fields and sort them
    Dim i As Long
    For i = 1 To pvt.RowFields.Count
        Set pvtField = pvt.RowFields(i)
        Call SortPivotFieldItems(i, pvt, pvtField)
    Next i
    
    pvt.ManualUpdate = False
    
Cleanup:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then
        MsgBox "An error occurred: " & Err.Description, vbCritical
    End If
End Sub

Sub SortPivotFieldItems(fieldIndex As Long, pvt As PivotTable, pvtField As PivotField)
    Dim foundValue As String
    Dim itemCount As Long
    Dim itemNames() As String
    Dim itemValues() As Double
    Dim i As Long
    Dim dataField As PivotField
    Dim pvtItem As PivotItem
    
    foundValue = "Number"
    
    ' Initialize Regex object using Late Binding
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "(^|\s)" & foundValue & "$"
        .IgnoreCase = True
        .Global = False
    End With
    
    Set dataField = Nothing
    For Each dataField In pvt.DataFields
        If regex.Test(dataField.Name) Then Exit For
    Next dataField
    If dataField Is Nothing Then
        MsgBox "'" + foundValue + "' data field not found in the PivotTable.", vbExclamation
        Exit Sub
    End If
    
    ' Get the number of items in the field
    itemCount = pvtField.PivotItems.Count
    ReDim itemNames(1 To itemCount)
    ReDim itemValues(1 To itemCount)
    
    ' Collect item names and their corresponding values
    Dim fieldArgs() As String
    Dim fieldArgsString As String
    Dim j As Long
    Dim topLeftCell As String
    topLeftCell = pvt.TableRange2.Cells(1, 1).Address()
    For i = 1 To itemCount
        Set pvtItem = pvtField.PivotItems(i)
        itemNames(i) = fieldIndex & "_" & pvtItem.Name ' Prefix the item name to ensure uniqueness across fields
        On Error Resume Next
        ' Attempt to get the value associated with the pivot item
        ReDim fieldArgs(1 To fieldIndex * 2)
        For j = 1 To fieldIndex ' Loop through all row fields up to the current hierarchy level
            fieldArgs(2 * j - 1) = Chr(34) & pvt.RowFields(j).Name & Chr(34)
            'fieldArgs(2 * j) = Chr(34) & pvt.RowFields(j).PivotItems(i).Name & Chr(34)
            'fieldArgs(2 * j) = Chr(34) & pvt.DataBodyRange.Cells(i, j).Value & Chr(34)
            fieldArgs(2 * j) = Chr(34) & pvt.RowFields(j).PivotItems(pvtItem.Position).Name & Chr(34)

        Next j
        fieldArgsString = "GetPivotData(" & Chr(34) & foundValue & Chr(34) & ", " & topLeftCell & ", " & Join(fieldArgs, ", ") & ")"
        itemValues(i) = Evaluate(fieldArgsString)
        MsgBox fieldArgsString & vbNewLine & itemNames(i) & " is " & itemValues(i)
        If Err.Number <> 0 Then
            itemNames(i) = vbNullString
            itemValues(i) = 0 ' Or handle as appropriate
            Err.Clear
        End If
        On Error GoTo 0
    Next i

    ' Sort the items using QuickSort (descending order based on values)
    Call QuickSort(itemNames, itemValues, LBound(itemValues), UBound(itemValues))
    
    ' Set the positions of the items to reflect the new order
    Dim originalItemName As String
    For i = 1 To itemCount
        If itemNames(i) <> vbNullString Then
            ' pvtField.PivotItems(itemNames(i)).Position = i
            ' Extract the original item name by removing the prefix
            originalItemName = Mid(itemNames(i), InStr(itemNames(i), "_") + 1)
            'MsgBox itemNames(i) & " " & itemValues(i)
            pvtField.PivotItems(originalItemName).Position = i
        End If
    Next i
End Sub

Sub QuickSort(arrNames() As String, arrValues() As Double, ByVal first As Long, ByVal last As Long)
    Dim low As Long, high As Long
    Dim midVal As Double
    Dim tempName As String
    Dim tempValue As Double
    
    low = first
    high = last
    midVal = arrValues((first + last) \ 2)
    
    Do While low <= high
        Do While arrValues(low) > midVal ' For descending order
            low = low + 1
        Loop
        Do While arrValues(high) < midVal
            high = high - 1
        Loop
        If low <= high Then
            ' Swap values
            tempValue = arrValues(low)
            arrValues(low) = arrValues(high)
            arrValues(high) = tempValue
            
            ' Swap names
            tempName = arrNames(low)
            arrNames(low) = arrNames(high)
            arrNames(high) = tempName
            
            low = low + 1
            high = high - 1
        End If
    Loop
    
    ' Recursive calls
    If first < high Then Call QuickSort(arrNames, arrValues, first, high)
    If low < last Then Call QuickSort(arrNames, arrValues, low, last)
End Sub

So while it doesn't seem to be explicitly documented, .position = X doesn't support GetPivotData. In other words, the position is set statically under a specific pivotfield level and not dynamically based on combinations of pivotfields. So while in this example Child c is smaller in Parent a but bigger in parent b, in reality it can only have one position.

I've therefore prepared code that just determines the position based on each pivotfield - note it gets stuck on large data though, despite trying to overcome it with ignoring duplicated names and shutting off slow downs:

Sub ManualSortPivotNow()
    Call ManualSortPivot
End Sub

Sub ManualSortPivot(Optional pvt As PivotTable)
    On Error GoTo Cleanup ' Ensure events are re-enabled on error
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    If pvt Is Nothing Then
        On Error Resume Next
        Set pvt = ActiveSheet.PivotTables(1)
        If pvt Is Nothing Then
            MsgBox "No PivotTable provided and no PivotTables found on the ActiveSheet.", vbExclamation
            GoTo Cleanup
        End If
        On Error GoTo Cleanup
    End If
    
    Dim theDatafield As String
    Dim pf As PivotField
    theDatafield = "Number"
    Dim fieldExists As Boolean
    fieldExists = False
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "(^|\s)" & theDatafield & "$"
        .IgnoreCase = True
        .Global = False
    End With
    For Each pf In pvt.DataFields
        If regex.Test(pf.Name) Then
            fieldExists = True
            Exit For
        End If
    Next
    If Not fieldExists Then
        MsgBox "The '" & theDatafield & "' field does not exist in the PivotTable.", vbExclamation
    End If
    
    For Each pf In pvt.RowFields
        Dim pivotItemsArray() As Variant
        Dim pivotValuesArray() As Double
        Dim itemCount As Long
        Dim dict As Object
        Set dict = CreateObject("Scripting.Dictionary")
        itemCount = pf.PivotItems.Count
        ReDim pivotItemsArray(1 To itemCount)
        ReDim pivotValuesArray(1 To itemCount)
        Dim uniqueCount As Long
        uniqueCount = 0
        
        On Error Resume Next
        For i = 1 To itemCount
            Dim pivotItemName As String
            pivotItemName = pf.PivotItems(i).Name
            
            ' Only process unique items by using the dictionary
            If Not dict.exists(pivotItemName) Then
                uniqueCount = uniqueCount + 1
                pivotItemsArray(uniqueCount) = pivotItemName
                pivotValuesArray(uniqueCount) = ThisWorkbook.Sheets(1).PivotTables(1).GetPivotData(theDatafield, pf.Name, pivotItemName)
                dict.Add pivotItemName, True ' Mark the item as processed
            End If
        Next i
        On Error GoTo Cleanup

        ReDim Preserve pivotItemsArray(1 To uniqueCount)
        ReDim Preserve pivotValuesArray(1 To uniqueCount)
            
        pvt.ManualUpdate = False
        QuickSort pivotItemsArray, pivotValuesArray, LBound(pivotItemsArray), UBound(pivotItemsArray), pf
        pvt.ManualUpdate = True
    Next pf
    
Cleanup:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then
        MsgBox "An error occurred: " & Err.Description, vbCritical
    End If
End Sub

Sub QuickSort(ByRef arrItems As Variant, ByRef arrValues As Variant, ByVal low As Long, ByVal high As Long, ByRef pf As PivotField)
    Dim i As Long, j As Long, pivot As Double, temp As Variant
    i = low
    j = high
    pivot = arrValues((low + high) \ 2) ' Choose pivot point

    ' Partition
    Do While i <= j
        Do While arrValues(i) > pivot: i = i + 1: Loop
        Do While arrValues(j) < pivot: j = j - 1: Loop
        If i <= j Then
            ' Swap the values
            temp = arrValues(i)
            arrValues(i) = arrValues(j)
            arrValues(j) = temp
            ' Swap the corresponding items
            temp = arrItems(i)
            arrItems(i) = arrItems(j)
            arrItems(j) = temp
            ' Set the positions in the PivotField as they are swapped
            pf.PivotItems(arrItems(i)).Position = i
            pf.PivotItems(arrItems(j)).Position = j
            i = i + 1
            j = j - 1
        End If
    Loop

    ' Recursive QuickSort calls
    If low < j Then QuickSort arrItems, arrValues, low, j, pf
    If i < high Then QuickSort arrItems, arrValues, i, high, pf
End Sub