我之前帮朋友处理过几乎一模一样的场景，你这个问题的核心不是等待时间不够，而是数据透视表没有在切换数据验证值后被主动触发刷新，再加上Excel的异步计算机制，导致图表还没完成重绘就被复制粘贴了——单纯的Wait函数只是让程序暂停，根本没触发表底层的刷新逻辑。

问题根源拆解 #

• 数据验证列表切换后，Excel只会更新关联的单元格，但不会自动刷新依赖的透视表（除非你设置了“打开文件时刷新”，但批量循环时这个触发逻辑不生效）
• 如果你的VBA里关闭了ScreenUpdating，Excel会暂停大部分界面重绘，包括透视表的更新，图表自然还是用旧数据
• 复制粘贴的时机太早，图表还没完成数据源同步就被导出了

针对性解决方案 #

下面是修改后的代码，核心是在切换数据验证值后，强制刷新透视表缓存+透视表本身，再让Excel完成所有计算和重绘，最后再执行复制粘贴：

Sub ExportChartsToPPT()
    Dim pptApp As Object, pptPres As Object
    Dim ws As Worksheet
    Dim validationRange As Range, listItem As Range
    Dim targetPivot As PivotTable, pivotCacheObj As PivotCache
    Dim copyRange As Range
    
    ' 替换成你的实际工作表名称
    Set ws = ThisWorkbook.Worksheets("DataSheet")
    ' 替换成你的数据验证列表所在单元格范围
    Set validationRange = ws.Range("ValidationListRange")
    ' 替换成你的数据验证下拉单元格（就是切换选项的那个单元格）
    Dim validationCell As Range
    Set validationCell = ws.Range("ValidationDropdownCell")
    ' 替换成要复制的图表/表格区域
    Set copyRange = ws.Range("ExportRange")
    ' 替换成你的目标透视表名称
    Set targetPivot = ws.PivotTables("SalesPivot")
    
    ' 初始化PPT应用
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add
    
    ' 关闭屏幕更新提升执行效率，最后记得恢复
    Application.ScreenUpdating = False
    ' 禁用Excel警告弹窗，避免中断流程
    Application.DisplayAlerts = False
    
    For Each listItem In validationRange
        ' 1. 切换数据验证选项
        validationCell.Value = listItem.Value
        
        ' 2. 强制刷新透视表（关键步骤！）
        Set pivotCacheObj = targetPivot.PivotCache
        pivotCacheObj.Refresh ' 先刷新数据源缓存
        targetPivot.RefreshTable ' 再刷新透视表本身
        
        ' 3. 让Excel完成所有计算和异步任务，确保图表完全更新
        Application.CalculateUntilAsyncQueriesDone
        DoEvents ' 释放系统资源，让图表完成重绘
        
        ' 4. 复制并粘贴到PPT
        copyRange.Copy
        With pptPres.Slides.Add(pptPres.Slides.Count + 1, 12) ' 12代表空白幻灯片版式
            ' 粘贴为可编辑的Excel对象（要静态图就把DataType改成2）
            .Shapes.PasteSpecial DataType:=-2
            ' 调整粘贴内容的位置，按需修改数值
            .Shapes(.Shapes.Count).Top = 50
            .Shapes(.Shapes.Count).Left = 50
        End With
        
        ' 清空剪贴板，避免内存占用
        Application.CutCopyMode = False
    Next listItem
    
    ' 恢复Excel的默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "所有图表已成功导出到PPT！", vbInformation
End Sub

额外注意事项 #

• 请把代码里的所有占位符替换成你实际的工作表名称、单元格范围、透视表名称
• 如果有多个依赖的透视表，要逐个执行Refresh和RefreshTable操作
• 粘贴方式选择：DataType:=-2是粘贴为可编辑的Excel图表对象，DataType:=2是粘贴为静态图片，按需选择
• 建议加入错误处理模块，避免中途出错导致ScreenUpdating一直处于关闭状态

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