无法创建Pivot Table：VBA代码失效，求助排查数据或代码问题

此前可正常运行的VBA数据透视表生成代码目前失效，无法确定是数据源问题还是代码本身导致。以下是完整代码，重点关注透视缓存（Pivot Cache）创建数据透视表的核心部分：

Sub CreatePivotTable()
' 引用当前活动工作表
Dim wsData As Worksheet
Set wsData = ActiveSheet

' 为PivotTable新建工作表
Dim wsPivot As Worksheet
Set wsPivot = Worksheets.Add

' 将新工作表命名为"PivotTable"
wsPivot.Name = "Pivot"

' 定义数据范围（当前活动工作表的已用区域）
Dim dataRange As Range
Set dataRange = wsData.UsedRange

' 在新工作表上创建PivotTable
Dim pivotCache As pivotCache
Dim pivotTable As pivotTable

' 使用数据范围创建PivotCache
Set pivotCache = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)

' 使用PivotCache创建PivotTable
Set pivotTable = pivotCache.CreatePivotTable(TableDestination:=wsPivot.Range("A3"), TableName:="Pivot")

' 设置PivotTable字段
With pivotTable.PivotFields("Product #")
    .Orientation = xlRowField
    .Position = 1
    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With

With pivotTable.PivotFields("Product Description")
    .Orientation = xlRowField
    .Position = 2
    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With

With pivotTable.PivotFields("DA")
    .Orientation = xlDataField
    .Function = xlSum
    .Position = 1
    .NumberFormat = "#,##0.00" ' 根据需要调整数字格式
End With

' 设置PivotTable选项
pivotTable.DisplayFieldCaptions = False ' 隐藏字段标题
pivotTable.RowAxisLayout xlTabularRow ' 设置为表格形式

' 删除第1行和第2行
wsPivot.Rows("1:2").Delete

' 在D2单元格插入"RMB"，E2单元格插入"VAr"
wsPivot.Range("D2").Value = "RMB"
wsPivot.Range("E2").Value = "VAr"

' 对D2:E2区域设置自动筛选
wsPivot.Range("D2:E2").AutoFilter

 ' 在E3单元格插入公式，计算C列和D列数值的差值
wsPivot.Range("E3").Formula = "=C3-D3"

' 将公式向下填充至列末
wsPivot.Range("E3").AutoFill Destination:=wsPivot.Range("E3:E" & wsPivot.Cells(wsPivot.Rows.Count, "C").End(xlUp).Row)

' 在D3单元格插入SUMIFS公式
wsPivot.Range("D3").Formula = "=SUMIFS(Work2!E:E, Work2!K:K, A3)"

' 将公式向下填充至倒数第二行
wsPivot.Range("D3").AutoFill Destination:=wsPivot.Range("D3:D" & wsPivot.Cells(wsPivot.Rows.Count, "C").End(xlUp).Row - 1)

' 在D列最后一行插入公式，求和Work2工作表E列所有数值
Dim lastRow As Long
lastRow = wsPivot.Cells(wsPivot.Rows.Count, "C").End(xlUp).Row
wsPivot.Cells(lastRow, "D").Formula = "=SUM(Work2!E:E)"

' 激活新工作表
wsPivot.Activate
End Sub

可能的故障原因及解决办法 #

1. 数据源范围识别错误 #

• 问题：UsedRange可能包含空行/空列，或数据源表头缺失、字段名重复，导致透视缓存无法正确识别数据结构。
• 解决：
  • 手动检查数据源工作表，确保表头行无空值、无重复字段名，数据区域无整行/整列空值。
  • 替换UsedRange为更精确的动态范围：

    ' 使用CurrentRegion获取连续数据区域
    Set dataRange = wsData.Range("A1").CurrentRegion
    ' 或通过计算最后行列确定范围
    Dim lastCol As Long, lastRow As Long
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    lastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
    Set dataRange = wsData.Range(wsData.Cells(1, 1), wsData.Cells(lastRow, lastCol))
    

2. 透视表名称冲突 #

• 问题：工作簿中已存在名为"Pivot"的数据透视表，导致新表创建失败。
• 解决：
  • 修改透视表名称为唯一值，比如加入时间戳避免重复：

    Set pivotTable = pivotCache.CreatePivotTable(TableDestination:=wsPivot.Range("A3"), TableName:="Pivot_" & Format(Now(), "YYYYMMDDHHMMSS"))
    

  • 或提前检查并删除同名透视表：

    On Error Resume Next
    ThisWorkbook.PivotTables("Pivot").TableRange2.Delete
    On Error GoTo 0
    

3. 透视缓存参数兼容性问题 #

• 问题：部分Excel版本对SourceData传入Range对象支持不佳，需转为带工作表名称的地址字符串。
• 解决：调整透视缓存创建代码：

  Set pivotCache = ThisWorkbook.PivotCaches.Create( _
      SourceType:=xlDatabase, _
      SourceData:=dataRange.Address(External:=True) _
  )
  

4. 字段名称不匹配 #

• 问题：代码中引用的"Product #"、"Product Description"、"DA"字段在数据源中不存在，或存在拼写、大小写、空格差异。
• 解决：
  • 核对数据源表头字段名，确保与代码引用完全一致。
  • 可添加字段存在性检查，提前报错终止：

    On Error Resume Next
    Dim fld As PivotField
    Set fld = pivotTable.PivotFields("Product #")
    If Err.Number <> 0 Then
        MsgBox "数据源中不存在字段：Product #"
        Exit Sub
    End If
    On Error GoTo 0
    

5. 工作表操作时序问题 #

• 问题：删除行、插入公式的操作可能在透视表未完全渲染时执行，导致单元格引用错误。
• 解决：在创建透视表后加入DoEvents，确保Excel完成透视表渲染再执行后续操作：

  Set pivotTable = pivotCache.CreatePivotTable(TableDestination:=wsPivot.Range("A3"), TableName:="Pivot")
  ' 添加该行确保透视表完全生成
  DoEvents
  

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