如何通过VBA宏修改Pivot Table源数据范围及解决运行时错误'5'

问题背景 #

我的数据集每周会导入新数据，需要调整其数据范围，因此尝试编写VBA宏实现该自动化任务。当前遇到两个问题：

• 未找到针对该需求的标准解决方案
• 尝试的方法返回「运行时错误'5'」

原代码 #

Option Explicit

Sub ListPivotsInfor()
'Update 20141112
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim St As Worksheet
    Dim NewSt As Worksheet
    Dim pt As PivotTable
   
    
    Application.ScreenUpdating = False
    For Each St In ActiveWorkbook.Worksheets
        'Debug.Print St.Name
        For Each pt In St.PivotTables
                Debug.Print Worksheets("DADOS").Range("A6")
                'pt.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=, Version:=7)
                Dim ptbl As PivotTable: Set ptbl = pt
                ptbl.ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Sheets("DADOS").Range("A2:AD281"), Version:=7)
            Next
        Next
    Application.ScreenUpdating = True
End Sub

期望效果：扩大新增数据的范围，并更新工作簿中的所有Pivot Table和图表。

错误分析与解决方案 #

运行时错误'5'的原因 #

1. 硬编码固定数据范围：原代码中Sheets("DADOS").Range("A2:AD281")是固定范围，新增数据后范围不匹配，且数据源结构变化时会导致引用无效。
2. 重复创建透视缓存：每次循环都新建PivotCache，既降低效率，也可能触发权限或引用类错误。
3. 冗余变量：ptbl变量无实际作用，直接使用pt即可。

修正后的代码 #

Option Explicit

Sub UpdateAllPivotsAndCharts()
    Dim wb As Workbook
    Dim dataWS As Worksheet
    Dim pivotWS As Worksheet
    Dim pt As PivotTable
    Dim dataRange As Range
    Dim newPivotCache As PivotCache
    
    Set wb = ThisWorkbook
    Set dataWS = wb.Worksheets("DADOS")
    
    ' 获取动态数据源范围（从A2到AD列最后一行有效数据）
    Set dataRange = dataWS.Range("A2:" & dataWS.Cells(dataWS.Rows.Count, "AD").End(xlUp).Address)
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 仅创建一次新透视缓存，复用给所有透视表
    Set newPivotCache = wb.PivotCaches.Create( _
        SourceType:=xlDatabase, _
        SourceData:=dataRange, _
        Version:=xlPivotTableVersion15 ' 对应Excel 2013及以上版本，可根据实际版本调整
    )
    
    ' 更新所有透视表
    For Each pivotWS In wb.Worksheets
        For Each pt In pivotWS.PivotTables
            pt.ChangePivotCache newPivotCache
            pt.RefreshTable
        Next pt
    Next pivotWS
    
    ' 更新所有关联图表
    Dim chrt As ChartObject
    For Each pivotWS In wb.Worksheets
        For Each chrt In pivotWS.ChartObjects
            chrt.Chart.Refresh
        Next chrt
    Next pivotWS
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

关键改进点 #

• 动态数据源：通过End(xlUp)自动定位AD列最后一行有效数据，确保每次都包含最新导入的内容。
• 缓存复用：仅创建一次PivotCache，避免重复操作引发的错误和性能损耗。
• 同步更新图表：遍历所有工作表的图表对象并刷新，保证图表与透视表数据同步。
• 优化运行效率：关闭屏幕更新和事件触发，减少界面闪烁并提升宏的运行速度。

内容的提问来源于stack exchange，提问作者Eng Victor Oliveira