AutoSort受阻时，用VBA实现Excel透视表按数值降序定位

Excel存在限制：AutoSort和AutoShow无法用于使用位置引用的自定义计算，例如% Difference From (previous)这类计算。但Excel允许手动调整行位置，既可以通过拖拽操作实现，也能通过VBA语句PivotFields(...).PivotItems(...).position = X完成。

现需通过VBA自动实现按Number字段降序排列的数据透视表行定位，效果与手动拖拽排序后的结果一致。

示例数据 #

创建包含Parent-Child-Number-% Difference From的透视表后，默认显示为初始状态；手动拖拽按Number排序后为目标状态。

目前已实现通过VBA按Parent字段自动定位，但Child字段无法正常排序，问题疑似出在代码行：

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

完整调试代码 #

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

内容的提问来源于stack exchange，提问作者LWC