创建指定名称的动态数据透视表工作表技术求助

需求 #

• 创建三个指定名称的工作表：
  • 基于ReceivedMacro数据的透视表工作表（命名为ReceivedPivot）
  • 基于ResolvedMacro数据的透视表工作表（命名为ResolvedPivot）
  • 基于ReceivedMacroAge数据的统计工作表（命名为CaseAgeStats）
• 再次运行代码时，自动删除已存在的上述工作表，避免重复创建

问题背景 #

此前尝试其他代码实现时，创建数据透视表无法识别动态数据源范围，导致报错，以下是调整后的可用代码，解决了动态范围问题并实现了工作表的自动替换。

完整VBA代码 #

Sub MacroPivotReceivedResolved()
    Dim wb As Workbook
    Dim wsReceived As Worksheet, wsResolved As Worksheet, wsAge As Worksheet
    Dim wsPivotReceived As Worksheet, wsPivotResolved As Worksheet, wsStats As Worksheet
    Dim pivotCache As PivotCache
    Dim pivotTable As PivotTable
    Dim lastRow As Long, lastCol As Long
    Dim dataRange As Range
    
    Set wb = ThisWorkbook
    ' 定义源工作表
    Set wsReceived = wb.Worksheets("ReceivedMacro")
    Set wsResolved = wb.Worksheets("ResolvedMacro")
    Set wsAge = wb.Worksheets("ReceivedMacroAge")
    
    ' 步骤1：删除已存在的目标工作表（避免重复）
    DeleteWorksheet wb, "ReceivedPivot"
    DeleteWorksheet wb, "ResolvedPivot"
    DeleteWorksheet wb, "CaseAgeStats"
    
    ' 步骤2：创建Received数据透视表工作表
    Set wsPivotReceived = wb.Worksheets.Add
    wsPivotReceived.Name = "ReceivedPivot"
    ' 获取ReceivedMacro的动态数据源范围
    With wsReceived
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
        Set dataRange = .Range(.Cells(6, 1), .Cells(lastRow, lastCol))
    End With
    ' 创建透视缓存与透视表
    Set pivotCache = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)
    Set pivotTable = pivotCache.CreatePivotTable(TableDestination:=wsPivotReceived.Cells(3, 1), TableName:="PivotReceived")
    ' 设置透视表字段
    With pivotTable
        .RowAxisLayout xlTabularRow
        With .PivotFields("Receipt Date")
            .Orientation = xlRowField
            .Position = 1
        End With
        .AddDataField .PivotFields("Receipt Date"), "Count of Case Age", xlCount
    End With
    
    ' 步骤3：创建Resolved数据透视表工作表
    Set wsPivotResolved = wb.Worksheets.Add
    wsPivotResolved.Name = "ResolvedPivot"
    ' 获取ResolvedMacro的动态数据源范围
    With wsResolved
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
        Set dataRange = .Range(.Cells(6, 1), .Cells(lastRow, lastCol))
    End With
    ' 创建透视缓存与透视表
    Set pivotCache = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)
    Set pivotTable = pivotCache.CreatePivotTable(TableDestination:=wsPivotResolved.Cells(3, 1), TableName:="PivotResolved")
    ' 设置透视表字段
    With pivotTable
        .RowAxisLayout xlTabularRow
        With .PivotFields("Resolved Date")
            .Orientation = xlRowField
            .Position = 1
        End With
        .AddDataField .PivotFields("Resolved Date"), "Count of Case Age", xlCount
    End With
    
    ' 步骤4：创建Case Age统计工作表
    Set wsStats = wb.Worksheets.Add(After:=wsAge)
    wsStats.Name = "CaseAgeStats"
    ' 复制ReceivedMacroAge的动态数据范围
    With wsAge
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
        .Range(.Cells(6, 1), .Cells(lastRow, lastCol)).Copy wsStats.Cells(1, 1)
    End With
    Application.CutCopyMode = False
    
    ' 设置统计工作表格式
    With wsStats.Cells
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
        .ColumnWidth = 17.57
    End With
    wsStats.Columns("A:A").ColumnWidth = 16.29
    
    ' 添加统计公式区域
    wsStats.Rows("1:9").Insert Shift:=xlDown
    ' 写入统计标题与公式
    With wsStats
        .Range("H1").Value = "Total Outstanding"
        .Range("I1").FormulaR1C1 = "=SUM(R[1]C:R[5]C)"
        
        .Range("H2").Value = "Over 8 Weeks (Over 56 Days)"
        .Range("I2").FormulaR1C1 = "=COUNTIFS(R[9]C:R[1000]C, "">=57"")"
        
        .Range("H3").Value = "6-8 Weeks (42-56 days)"
        .Range("I3").FormulaR1C1 = "=SUMPRODUCT(INT(R[9]C:R[1000]C>=42), INT(R[9]C:R[1000]C<57))"
        
        .Range("H4").Value = "4-6 weeks (28 - 41)"
        .Range("I4").FormulaR1C1 = "=SUMPRODUCT(INT(R[9]C:R[1000]C>=28), INT(R[9]C:R[1000]C<42))"
        
        .Range("H5").Value = "2-4 Weeks (14 - 27)"
        .Range("I5").FormulaR1C1 = "=SUMPRODUCT(INT(R[9]C:R[1000]C>=14), INT(R[9]C:R[1000]C<28))"
        
        .Range("H6").Value = "0-2 Weeks (0-13)"
        .Range("I6").FormulaR1C1 = "=SUMPRODUCT(INT(R[9]C:R[1000]C>=1), INT(R[9]C:R[1000]C<14))"
        
        .Range("H7").Value = "Cases to breach next day (Day 56)"
        .Range("I7").FormulaR1C1 = "=COUNTIFS(R[9]C:R[1000]C, ""=56"")"
    End With
End Sub

' 辅助函数：删除指定名称的工作表（如果存在）
Sub DeleteWorksheet(wb As Workbook, wsName As String)
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(wsName)
    On Error GoTo 0
    If Not ws Is Nothing Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
End Sub

关键改进说明 #

1. 工作表自动替换：新增DeleteWorksheet辅助函数，运行时先检查目标工作表是否存在，存在则自动删除，避免重复创建导致的错误
2. 动态数据源范围：通过lastRow和lastCol获取源数据的实际边界，替代原代码中固定的R6C1:R20000C54范围，解决了动态数据报错的问题
3. 取消选择操作：移除原代码中大量的Select/Selection操作，改用对象直接引用，提升代码稳定性与运行效率
4. 明确工作表命名：给三个目标工作表指定固定名称，便于后续识别与维护

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