当自动排序被阻止时，VBA 手动定位 Excel 枢轴

Question

您可能知道，“自动排序和自动显示不能与使用位置引用的自定义计算一起使用”，例如 （上一个） 的 % Difference From。

但是 Excel 不介意您以任何您想要的方式手动定位行。可以通过拖放手动完成，也可以通过

PivotFields(...).PivotItems(...).position = X

使用 VBA 完成。问题是如何在 VBA 中按数字降序自动执行此操作，如第二个屏幕截图所示？

如果行数据是：

家长	孩子	数量
c	a	2432423
b	c	634
c	c	634
a	a	34
b	c	34
a	b	1
b	a	2
b	测试	453

然后父子编号-％差异的主元看起来像：

如果我通过数字手动定位它（通过拖动），那么它看起来与我想要的类似：

我已经成功地按父级自动定位，但不按子级自动定位，代码如下（只需运行

ManualSortPivotNow

）。

我认为唯一的问题是

fieldArgs(2 * j) = Chr(34) & pvt.RowFields(j).PivotItems(pvtItem.Position).Name & Chr(34)

，因为它只能在Parent上正常工作。我留下了一些消息框来帮助调试。

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

Answer 1

因此，虽然似乎没有明确记录，但

.position = X

不支持

GetPivotData

。换句话说，位置是在特定数据透视字段级别下静态设置的，而不是基于数据透视字段的组合动态设置的。因此，虽然在此示例中，子级 c 在父级 a 中较小，但在父级 b 中较大，但实际上它只能有一个位置。

因此，我准备了仅根据每个数据透视字段确定位置的代码：

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