我有一个Excel工作表，它根据数据验证列表更新了许多图表和表格。 我有以下代码，它循环遍历已验证的列表，复制所选范围，并发布到新的 PowerPoint。
从数据透视表馈送的图表在整个复制和粘贴过程中不会更新。
谁能提供一些指导？ 我尝试过输入"等待"功能以及其他功能，例如
Application.Calculate
If Not Application.CalculationState = xlDone Then
DoEvents
End If
无济于事。 这是当前代码： (编辑为包括循环功能，但仍创建单独的PPT)
Sub Loop_Through_List()
Dim cell As Excel.Range
Dim rgDV As Excel.Range
Dim DV_Cell As Excel.Range
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim pvtTbl As PivotTable
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBLANK
Set DV_Cell = Range("A2")
Worksheets("Main Tab - Comp").Calculate
Set rgDV = Application.Range(Mid$(DV_Cell.Validation.Formula1, 2))
For Each cell In rgDV.Cells
DV_Cell.Value = cell.Value
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBLANK
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A3:AA52")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 0
myShape.Top = 0
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
Next
End Sub
好的。所以这不是你可能希望的灵丹妙药。我的目标是获取您的代码，对其进行一些更改，讨论一些一般想法/原则，希望能帮助您构建自己的解决方案。
其他用户可能希望参与进来，使其对解决您的任务更有用。 问题是有很多问题需要解决，其中大部分实际上更适合代码审查。
任务：
您希望循环显示单元格区域，并在 PowerPoint 演示文稿中将更新的区域从 Excel 重复复制到新幻灯片。
问题：
您正在创建 PowerPoint 和新 PowerPoint 演示文稿的重复实例，而不是将范围复制到同一演示文稿中的新幻灯片。
必需(伪代码)进程：
- 创建PowerPoint应用程序或获取现有应用程序
- 将此演示文稿设置为随后可以引用的变量
- 循环 Excel 区域，每次将范围复制到演示文稿中新添加的幻灯片
- 保存对演示文稿的更改并关闭(可选)
- 关闭PowerPoint(可选，但需要在某个时候发生，因此不会在后台挂起)
这基本上就是过程。你会想要错误处理等，但这超出了我打算放在这里的范围。
首先要做的是....
代码说明：
0) 选项显式
把它放在代码的顶部。它强制显式声明所有变量，并在它们的使用中查找拼写错误等。如果希望它始终打开，可以转到"解决方案资源管理器">>"项目">"属性">"编译"选项卡中选择一个项目。
1) 范围
您的过程的范围是隐式公开的，因此让我们明确说明这一点：
Public Sub Loop_Through_List()
2) 优化
您希望使用代码顶部的ScreenUpdating进行优化。没有人希望屏幕在开始时闪烁，直到您关闭屏幕更新。并记得在最后重新打开它！
请注意优化，如果您依赖范围粘贴的计算值，则会关闭计算。
Public Sub Loop_Through_List()
Application.ScreenUpdating = False
3) 变量和声明
您的"声明墙"：
Dim cell As Excel.Range
Dim rgDV As Excel.Range
Dim DV_Cell As Excel.Range
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim pvtTbl As PivotTable
我们可以削掉这堵墙：
a)变量可以声明尽可能接近其实际用途。这使得代码更易于阅读。请参阅完整代码，了解如何实现这一点。
b)Dim cell As Excel.Range- 不确定官方对此有何看法，但由于代码在 Excel 中运行，如果您完全限定您的范围，我认为您可以删除 Excel，即只是Dim cell As Excel.Range.
除了
c)给你的变量有意义的名称，不会引起混淆，即不cell，并且不是保留关键字，例如Call，编译器用来确定代码的结构
因此，当对象表示您正在迭代一系列单元格时，有意义的事情可能是：
Dim currentCell As Range
由于角色不会花费你任何东西，你可以慷慨地扩展
DV_Cell to DataValidationCell
就我个人而言，如果可能的话，也避免在变量名称中使用"_"。
网上有很多资源可以建议命名约定，包括避免匈牙利语符号和正确的使用大小写。一个例子是这样的。
d)后期绑定与早期绑定。 在以下情况下使用后期绑定 你说
Dim myPresentation As Object
这在分发代码时很好，并且您不知道用户拥有的应用程序版本。
您还可以使用早期绑定，特别是对于开发，因为它可以快速编译并提供对当前对象的智能感知，即在您键入时弹出关联的属性/方法列表。
早期绑定将是：
Dim myPresentation As Presentation
e)删除未使用的变量
可能是您没有包含所有代码，但当前没有pvtTbl，所以这一行，Dim pvtTbl As PivotTable，可以去。
f)使用变量来保存对象并完全限定对象。
它使代码更易于阅读，并确保您正在使用预期的对象。
所以这样做：
Dim targetBook As Workbook
Dim wsMain As Worksheet
Set targetBook = ThisWorkbook
Set wsMain = targetBook.Worksheets("Main Tab - Comp")
表示如下所示的行：
Set DV_Cell = Range("A2")
Worksheets("Main Tab - Comp").Calculate
变得清晰和具体
Set DV_Cell = wsMain.Range("A2")
wsMain.Calculate
注意：由于原始帖子中缺乏特异性，我不得不假设您的意思是DV_Cell的主要选项卡。
而这个：
Set rng = ThisWorkbook.ActiveSheet.Range("A3:AA52")
我不清楚ThisWorkbook.ActiveSheet是否wsMain但一定要使用实际的工作表名称。我已重写为：
Set rng = wsMain.Range("A3:AA52")
4) 代码排序
确保代码流遵循我在开始时描述的伪代码过程。或者，在你自己的过程中，尝试写出伪代码进程，进行感官检查，然后确保你的代码匹配。
一个例子是：
Worksheets("Main Tab - Comp").Calculate
我已将其重写为：
wsMain.Calculate
我把它放在循环中，因为我认为你想根据DV_Cell值的变化来刷新计算;在循环中发生变化。
5)模块化代码和单一责任原则
模块化代码是一种常见的做法。让一个子/功能做一件事。我在这里包括了一个示例， 函数GetPPT，说明如何提取演示文稿的获取。
引用橡皮鸭OOP VBA第1部分揭穿的东西
单一责任原则是一条黄金法则，但很难 像在任何其他语言中一样遵循 VBA：编写小过程 和做一件事的功能，更喜欢许多小型专用模块 超过更少，大的。
那篇文章中还有很多东西要看。
6) 幻灯片索引
在下面的行中，1 是幻灯片索引
Set mySlide = myPresentation.Slides.Add(1, 12)
如果要定位不同的幻灯片，则需要使用不同的索引。
7) 默认属性
DV_Cell.Value = currentCell.Value可以成为
DV_Cell = currentCell
.Value是 Range 对象的默认属性。您可以指定currentCell.Value或缩短为仅currentCell
8)递增的对象引用(听起来很花哨！
关于我前面的幻灯片索引评论。递增要粘贴的幻灯片和形状。
Set mySlide = .Slides.Add(.Slides.Count + 1, 12)
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
9) 下一页 循环中的控制变量
哪里有 ，
Next
，显式命名迭代器，即
Next currentCell
特别是通过多个循环，这使得阅读内容变得更加容易。
1O) 避免创建多个电源点/应用程序
除了确保在复制循环之外创建应用程序和新演示文稿外，还要确保演示文稿和 PowerPoint 应用程序的关闭/退出不在复制范围循环之外。
11) 保存演示文稿
根据演示文稿是否已存在，或者是否创建了新演示文稿，您将需要代码来指定保存更改的文件。
12) 释放资源
请记住在完成后摆脱PowerPoint应用程序。
.Quit
示例，不完美，代码：
Option Explicit
Public Sub Loop_Through_List() 'You can add a reference to MS Powerpoint in tools references to take advantage of faster early binding and intellisense
'Optimize Code
Application.ScreenUpdating = False 'optimization at start
Dim PowerPointApp As PowerPoint.Application 'Object
Set PowerPointApp = GetPPT 'We now have a powerpoint presenation
Dim myPresentation As Presentation 'Object
Dim mySlide As Slide 'Object
Dim myShape As PowerPoint.Shape 'Object
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBLANK
Dim targetBook As Workbook
Dim wsMain As Worksheet
Set targetBook = ThisWorkbook
Set wsMain = targetBook.Worksheets("Main Tab - Comp")
Dim currentCell As Range 'currentCell as range
Dim rgDV As Range
Dim DV_Cell As Range 'Excel.range not sure Excel is needed here
Dim rng As Range
Dim pvtTbl As PivotTable 'Where is this used?
Set DV_Cell = wsMain.Range("A2")
'********Note: this is an alternative for testing ***************
'Set rgDV = Application.Range(Mid$(DV_Cell.Validation.Formula1, 2)) 'so this returns a cell reference
Set rgDV = wsMain.Range("B2:B4")
'***************************************************************
For Each currentCell In rgDV.Cells
Debug.Print currentCell.Address
DV_Cell = currentCell
wsMain.Calculate 'Assume you now want a recalculation based on changing DV_Cell
With myPresentation
'Copy Range from Excel
Set rng = wsMain.Range("A3:AA52")
'Copy Excel Range
rng.Copy
Set mySlide = .Slides.Add(.Slides.Count + 1, 12) '12 = ppLayoutBLANK. The first number is the index
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 0
myShape.Top = 0
End With
'Clear The Clipboard
Application.CutCopyMode = False
Next currentCell
'Presentation Save code goes here. Depending on whether presentation already existed or you created a new presentation
'closing/quiting code
PowerPointApp.Quit
Application.ScreenUpdating = True
End Sub
Private Function GetPPT() As Object
Dim PowerPointApp As Object
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then
Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
PowerPointApp.Visible = True
End If
On Error GoTo 0
Set GetPPT = PowerPointApp
End Function