通过 VBA 将大量图表从 Excel 复制并粘贴到 PowerPoint
Copy and paste large number of charts from Excel to Power Point via VBA
我知道这个页面上已经有很多关于如何使用 VBA 将内容从 excel 复制到 ppt 的帖子（其中许多已经帮助了我）但我有一个相当奇怪的我尚未解决的问题：
任务相当标准：遍历具有多个sheet的excel工作簿，并将工作簿中包含的所有图表复制到ppt演示文稿中，每张幻灯片一张图表，并且始终相同布局。在我为此使用的代码下方
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
ch.Copy
With pptSlide.Shapes.Paste
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
如果我在我的玩具示例（2 sheets，总共 3 个图表）中使用上面的代码，它工作正常，但如果我将它应用到真实的东西，这是一个有 10-15 sheets 和每个 sheet 8 个图表。它应该在那里开始，但在某个（随机？）点，代码停止并给我这个错误消息
运行-时间错误：
形状（未知成员）：无效请求。剪贴板为空或包含不能粘贴到此处的数据。
我注意到代码崩溃的时间越早，我在幻灯片上放置的对象越多（这就是我在示例中保留文本和方框的原因，尽管并非绝对必要）。鉴于此和错误消息，我假设每次循环后可能无法正确清除剪贴板，所以我放入了一个部分来清除剪贴板但它没有解决问题。
有什么想法吗？
干杯
复制图表后，尝试添加 DoEvents 并将宏暂停几秒钟，然后再将其粘贴到幻灯片中。将其粘贴到您的幻灯片后也是如此。
因此，例如，首先添加以下函数来暂停您的代码。 . .
Sub PauseMacro(ByVal secs As Long)
Dim endTime As Single
endTime = Timer + secs
Do
DoEvents
Loop Until Timer > endTime
End Sub
然后尝试这样的事情。 . .
ch.Copy
DoEvents
PauseMacro 5 'pause for 5 seconds
With pptSlide.Shapes.Paste
DoEvents
PauseMacro 5 'pause for 5 seconds
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
你可能通过测试发现，你可以暂停不到5秒，也许3秒。
我的方法是将潜在的 time-consuming 操作拆分成单独的函数（请参阅下面的“''作为函数调用”）。当一个函数被调用时，然后必须return，似乎Excel/VBA/the-little-green-men-running-everything确保无论是什么操作都等到操作完成（图表完全添加到剪贴板，剪贴板内容完全粘贴，形状完全实例化等），然后继续。
这也意味着不必在执行期间强制执行可能不需要的延迟（通常建议的 Do Until 或 Loop Until 或 Wait）。
因此您的代码可能如下所示（警告：未经测试）
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = NewSlide(pptPres) '' Call as a Function
ch.Copy
Dim shp As PowerPoint.Shape
Set shp = NewShape(pptSlide) '' Call as a Function
With shp
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = NewBox(pptSlide) '' Call as a Function
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = NewTextBox(pptSlide) '' Call as a Function
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
Function NewSlide(pptPres As PowerPoint.Presentation) As PowerPoint.Slide
Set NewSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
End Function
Function NewShape(pptSlide As PowerPoint.Slide) As PowerPoint.Shape
Set NewShape = pptSlide.Shapes.Paste
End Function
Function NewBox(pptSlide As PowerPoint.Slide) As Object
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
Function NewTextBox(pptSlide As PowerPoint.Slide) As Object
Set NewTextBox = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
我知道这个页面上已经有很多关于如何使用 VBA 将内容从 excel 复制到 ppt 的帖子（其中许多已经帮助了我）但我有一个相当奇怪的我尚未解决的问题：
任务相当标准：遍历具有多个sheet的excel工作簿，并将工作簿中包含的所有图表复制到ppt演示文稿中，每张幻灯片一张图表，并且始终相同布局。在我为此使用的代码下方
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
ch.Copy
With pptSlide.Shapes.Paste
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
如果我在我的玩具示例（2 sheets，总共 3 个图表）中使用上面的代码，它工作正常，但如果我将它应用到真实的东西，这是一个有 10-15 sheets 和每个 sheet 8 个图表。它应该在那里开始，但在某个（随机？）点，代码停止并给我这个错误消息
运行-时间错误： 形状（未知成员）：无效请求。剪贴板为空或包含不能粘贴到此处的数据。
我注意到代码崩溃的时间越早，我在幻灯片上放置的对象越多（这就是我在示例中保留文本和方框的原因，尽管并非绝对必要）。鉴于此和错误消息，我假设每次循环后可能无法正确清除剪贴板，所以我放入了一个部分来清除剪贴板但它没有解决问题。
有什么想法吗？
干杯
复制图表后，尝试添加 DoEvents 并将宏暂停几秒钟，然后再将其粘贴到幻灯片中。将其粘贴到您的幻灯片后也是如此。
因此，例如，首先添加以下函数来暂停您的代码。 . .
Sub PauseMacro(ByVal secs As Long)
Dim endTime As Single
endTime = Timer + secs
Do
DoEvents
Loop Until Timer > endTime
End Sub
然后尝试这样的事情。 . .
ch.Copy
DoEvents
PauseMacro 5 'pause for 5 seconds
With pptSlide.Shapes.Paste
DoEvents
PauseMacro 5 'pause for 5 seconds
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
你可能通过测试发现，你可以暂停不到5秒，也许3秒。
我的方法是将潜在的 time-consuming 操作拆分成单独的函数（请参阅下面的“''作为函数调用”）。当一个函数被调用时，然后必须return，似乎Excel/VBA/the-little-green-men-running-everything确保无论是什么操作都等到操作完成（图表完全添加到剪贴板，剪贴板内容完全粘贴，形状完全实例化等），然后继续。
这也意味着不必在执行期间强制执行可能不需要的延迟（通常建议的 Do Until 或 Loop Until 或 Wait）。
因此您的代码可能如下所示（警告：未经测试）
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = NewSlide(pptPres) '' Call as a Function
ch.Copy
Dim shp As PowerPoint.Shape
Set shp = NewShape(pptSlide) '' Call as a Function
With shp
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = NewBox(pptSlide) '' Call as a Function
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = NewTextBox(pptSlide) '' Call as a Function
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
Function NewSlide(pptPres As PowerPoint.Presentation) As PowerPoint.Slide
Set NewSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
End Function
Function NewShape(pptSlide As PowerPoint.Slide) As PowerPoint.Shape
Set NewShape = pptSlide.Shapes.Paste
End Function
Function NewBox(pptSlide As PowerPoint.Slide) As Object
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
Function NewTextBox(pptSlide As PowerPoint.Slide) As Object
Set NewTextBox = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function