VBA实现数据透视表新增数据自动复制（适配周末特殊场景）

原代码的问题在于固定了监控范围，没有动态识别透视表中的日期和对应数据，也未处理周末特殊逻辑。以下是修改后的实现方案：

核心思路 #

1. 改用透视表刷新完成事件触发，保证数据加载完成后再执行复制逻辑
2. 根据当前日期判断要查找的目标日期（周一取当日数据，周六周日取当日数据）
3. 动态在透视表中定位目标日期，复制对应数据行

修改后的代码 #

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim targetDate As Date
    Dim dateCell As Range
    Dim dataRow As Range
    
    ' 替换为你的透视表所在工作表名称
    Set ws = ThisWorkbook.Worksheets("透视表Sheet")
    ' 替换为你的透视表名称
    Set pt = ws.PivotTables("销售数据透视表")
    
    ' 根据当前星期确定目标日期
    Select Case Weekday(Date, vbMonday) ' 周一=1，周日=7
        Case 1 ' 周一：取当日数据（若需同时取周六周日可扩展逻辑）
            targetDate = Date
        Case 6, 7 ' 周六/周日：取当日数据
            targetDate = Date
        Case Else ' 周二至周五：取当日数据
            targetDate = Date
    End Select
    
    ' 在透视表中查找目标日期（匹配格式需和透视表内一致）
    On Error Resume Next
    Set dateCell = pt.TableRange1.Find( _
        What:=Format(targetDate, "yyyy-mm-dd"), _
        LookIn:=xlValues, _
        LookAt:=xlWhole _
    )
    On Error GoTo 0
    
    If Not dateCell Is Nothing Then
        ' 假设日期在透视表第一列，数据在日期行的下一行（根据你的透视表结构调整）
        Set dataRow = dateCell.Offset(1, 0).Resize(1, pt.TableRange1.Columns.Count - 1)
        
        ' 复制到目标位置（替换为你要粘贴的工作表和起始单元格）
        dataRow.Copy Destination:=ThisWorkbook.Worksheets("数据归档").Range("A" & Cells(Rows.Count, "A").End(xlUp).Row + 1)
        ' 若只需复制值，可改用下面一行：
        ' ThisWorkbook.Worksheets("数据归档").Range("A" & Cells(Rows.Count, "A").End(xlUp).Row + 1).Resize(1, dataRow.Columns.Count).Value = dataRow.Value
    Else
        MsgBox "未找到日期：" & Format(targetDate, "yyyy-mm-dd") & " 的数据"
    End If
End Sub

关键细节说明 #

• 事件选择：使用Worksheet_PivotTableUpdate替代原Worksheet_Change，确保仅在透视表刷新完成后触发，避免数据未加载完全就执行操作
• 日期匹配：Find方法中的日期格式必须和透视表内显示的格式完全一致，比如透视表用yyyy/mm/dd就改成对应格式
• 透视表结构适配：如果你的透视表日期不在第一列，或者数据行位置不同，调整Offset和Resize的参数即可
• 周末扩展：若需要周一同时复制周六、周日的数据，可添加循环分别查找这两个日期并执行复制逻辑

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