VBA创建数据透视表平均值计算耗时过长及性能优化咨询

一、数据量承载说明 #

20万条数据完全可以正常使用Excel数据透视表。性能表现较好的前提下，数据承载量如下：

• 32位Excel：单表无过多冗余列、无复杂格式时，可顺畅承载50~100万行数据
• 64位Excel：硬件配置达标前提下，可顺畅承载千万行级数据
  你当前宏运行过慢的核心原因是代码未做性能优化配置，而非数据量超限。

二、性能优化核心方案 #

你提到的PivotFields赋值代码运行慢，是因为透视表默认每修改一个属性就自动刷新一次，加上未关闭系统无关运算，导致大量重复计算：

1. 宏运行开头关闭屏幕更新、手动计算、事件触发，运行结束后恢复
2. 透视表修改属性阶段开启手动更新，所有配置完成后再一次性刷新
3. 透视缓存创建时使用外部地址字符串代替Range对象引用，降低内存开销

三、需求满足说明 #

你列出的5项需求，优化后代码已全部实现：

• 表格格式：通过RowAxisLayout xlTabularRow + 指定表格样式实现
• 筛选同步更新总计：开启VisualTotals = True，筛选后仅统计可见项的总计
• 关闭行分类汇总：所有行字段已禁用默认分类汇总
• 重复所有项目标签：已配置RepeatAllLabels xlRepeatLabels
• 自动调整列宽：透视表生成后调用AutoFit适配列宽

四、优化后完整代码 #

Option Explicit

Dim wb As Workbook
Dim wsData As Worksheet, wsPT As Worksheet

Sub Create_Pivot_Table()
    Dim LR As Long, LC As Long ' 原Byte类型上限255，列数超过会报错，改为Long
    Dim DataRange As Range
    Dim PTCache As PivotCache
    Dim pt As PivotTable
    Dim st As String
    st = Now()
    
    ' 性能优化：关闭无关运算
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    On Error GoTo ErrHandler ' 出错时自动恢复系统设置
    
    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("Data")
    
    Call Delete_PT_Sheet
    
    With wsData
        LR = .Cells(Rows.Count, "A").End(xlUp).Row
        LC = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set DataRange = .Range(.Cells(1, 1), .Cells(LR, LC))
    End With
    
    Set wsPT = wb.Worksheets.Add
    wsPT.Name = "Pivot_Data"
    
    ' 性能优化：用外部地址创建缓存，比直接传Range对象效率高
    Set PTCache = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataRange.Address(ReferenceStyle:=xlR1C1, External:=True))
    Set pt = PTCache.CreatePivotTable(TableDestination:=wsPT.Range("A2"), TableName:="Data")
    
    With pt
        ' 性能优化：修改属性阶段关闭自动刷新，避免重复计算
        .ManualUpdate = True
        
        .ColumnGrand = True
        .HasAutoFormat = True
        .DisplayErrorString = False
        .DisplayNullString = True
        .EnableDrilldown = True
        .ErrorString = ""
        .MergeLabels = False
        .NullString = ""
        .PageFieldOrder = 2
        .PageFieldWrapCount = 0
        .PreserveFormatting = True
        .RowGrand = True
        .PrintTitles = False
        .RepeatItemsOnEachPrintedPage = True
        .TotalsAnnotation = False
        .CompactRowIndent = 1
        .VisualTotals = True ' 需求满足：筛选后总计仅统计可见项，同步更新
        .InGridDropZones = False
        .DisplayFieldCaptions = True
        .DisplayMemberPropertyTooltips = True
        .DisplayContextTooltips = True
        .ShowDrillIndicators = True
        .PrintDrillIndicators = False
        .AllowMultipleFilters = True
        .SortUsingCustomLists = True
        .DisplayImmediateItems = True
        .FieldListSortAscending = False
        .ShowValuesRow = False
        .RowAxisLayout xlTabularRow ' 设为表格格式
        .RepeatAllLabels xlRepeatLabels ' 重复所有项目标签
        .TableStyle2 = "TableStyleMedium2" ' 需求满足：指定表格样式，可按需修改样式名
        
        '// 筛选字段
        With .PivotFields("Region")
            .Orientation = xlPageField
            .EnableMultiplePageItems = True
            .Subtotals(1) = False
        End With
        
        '// 行字段1
        With .PivotFields("JNJ RM Code")
            .Orientation = xlRowField
            .Position = 1
            .LayoutBlankLine = False
            .Subtotals(1) = False ' 关闭分类汇总
            .LayoutForm = xlTabular
            .LayoutCompactRow = True
        End With
        
        '// 行字段2
        With .PivotFields("Component Description")
            .Orientation = xlRowField
            .Position = 2
            .LayoutBlankLine = False
            .Subtotals(1) = False
        End With
                
        '// 行字段3
        With .PivotFields("FG Material Code")
            .Orientation = xlRowField
            .Position = 3
            .LayoutBlankLine = False
            .Subtotals(1) = False
        End With
         
        '// 行字段4
        With .PivotFields("FG Material Description")
            .Orientation = xlRowField
            .Position = 4
            .LayoutBlankLine = False
            .Subtotals(1) = False
        End With
        
        '// 值字段
        With .PivotFields("NTS USD ACT Previous Year")
            .Orientation = xlDataField
            .Position = 1
            .Function = xlAverage
            .NumberFormat = "$#,##;($#,##);-"
            .Caption = "FG NTS PY-Average"
        End With
        
        ' 所有配置完成，开启自动更新刷新透视表
        .ManualUpdate = False
    End With
    
    ' 需求满足：自动调整列宽
    wsPT.UsedRange.EntireColumn.AutoFit
    
    ThisWorkbook.Save
    
ErrHandler:
    ' 恢复系统默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    ' 释放对象内存
    Set PTCache = Nothing
    Set pt = Nothing
    Set wsPT = Nothing
    Set DataRange = Nothing
    Set wsData = Nothing
    Set wb = Nothing
    
    If Err.Number <> 0 Then
        MsgBox "运行出错：" & Err.Description, vbCritical
    End If
End Sub

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