从Excel中，我需要打开一个PowerPoint模板，遍历每张幻灯片并使用占位符的替代文本字段中的一些数据，将它们与Excel中的图表匹配，然后将其复制到PowerPoint幻灯片中的该位置。
搜索后我找到了一些代码，我已经修改了这些代码以实现我的目标。它适用于Win7 Enterprise，但是当我在Win10 Enterprise中运行相同的代码时，我收到以下错误：
System Error &H800706BE (-2147023170). The remote procedure call failed.
以下是我的代码，对我可能做错的任何帮助或Win10中可能导致我的问题的更改都将非常感激。我正在运行Office 365 ProPlus。
Public Sub QBR_Deck()
'#
'# Set reference to 'Microsoft PowerPoint <current version> Object Library' in the VBE via Tools > References...
'#
'#
'# Declare variables
'#
Dim app_PowerPoint As PowerPoint.Application
Dim ppt_Presentation As PowerPoint.Presentation
Dim obj_PPTSlide As PowerPoint.Slide
Dim obj_PPTShape As PowerPoint.Shape
Dim obj_ExcelChart As Chart
Dim obj_ExcelWorksheet As Worksheet
Dim obj_ExcelObject As ListObject
Dim lng_i As Long
Dim var_Parameters As Variant
Dim str_PPTTemplatePath As String
'#
'# Allow user to select PPT template
'# Set path to same location as spreadsheet
'#
str_PPTTemplatePath = Application.GetOpenFilename(Title:="PowerPoint Template")
If str_PPTTemplatePath = "False" Then Exit Sub
'#
'# Get the PowerPoint Application object
'#
Set app_PowerPoint = CreateObject("PowerPoint.Application")
app_PowerPoint.Visible = msoTrue
Set ppt_Presentation = app_PowerPoint.Presentations.Open(str_PPTTemplatePath, untitled:=msoTrue)
'#
'# Review each slide and each shape on slide
'#
For Each obj_PPTSlide In ppt_Presentation.Slides
For Each obj_PPTShape In obj_PPTSlide.Shapes
'#
'# Determine when target shapes are located
'# Examine Alternative Text in PPT
'# Text for objects, will be in this format: @REPLACE|XLS_<chart_name>|PPT_<shape_Name>
'#
If Left$(obj_PPTShape.AlternativeText, 8) = "@REPLACE" Then
var_Parameters = Split(obj_PPTShape.AlternativeText, "|")
For Each obj_ExcelWorksheet In ActiveWorkbook.Worksheets
'#
'# Look at each chart on each worksheet
'# Use the Alternative Text to match each chart to the appropriate slide
'# Copy and paste onto slide
'#
For lng_i = obj_ExcelWorksheet.ChartObjects.Count To 1 Step -1
If obj_ExcelWorksheet.ChartObjects(lng_i).Name = var_Parameters(1) Then
obj_PPTSlide.Select
Set obj_ExcelChart = obj_ExcelWorksheet.ChartObjects(lng_i).Chart
obj_ExcelChart.ChartArea.Copy
app_PowerPoint.Activate
obj_PPTShape.Select
app_PowerPoint.Windows(1).View.Paste
app_PowerPoint.Windows(1).Selection.ShapeRange.Left = obj_PPTShape.Left
app_PowerPoint.Windows(1).Selection.ShapeRange.Top = obj_PPTShape.Top
app_PowerPoint.Windows(1).Selection.ShapeRange.Height = obj_PPTShape.Height
app_PowerPoint.Windows(1).Selection.ShapeRange.Width = obj_PPTShape.Width
obj_PPTShape.Delete
End If
Next lng_i
Next obj_ExcelWorksheet
End If 'Alternative Text not in expected format
Next obj_PPTShape
Next obj_PPTSlide
'#
'# Clean up on the way out
'#
Set ppt_Presentation = Nothing
Set app_PowerPoint = Nothing
End Sub
答案 0 :(得分：1)
Office 2016 Pro Plus，Windows 10（不是Office 365，但无关紧要）。
我注意到当你使用For Each obj_PPTShape In obj_PPTSlide.Shapes然后删除形状时，它会破坏循环。第二次循环时，它仍在考虑第一个已被删除的形状。
所以我介绍了一个形状计数器，从obj_PPTSlide.Shapes.Count开始并向后工作（你真的不需要在Excel幻灯片上的图表，BTW）。我还在删除形状后立即插入Exit For，因此您不会循环浏览图表，并且无法找到您已删除的形状。这对你来说可能不是问题，但是当我复制我的第一个图表以制作第二个图表并更改了图表名称时，新名称并没有第一次出现。
所以这是稍微调整过的代码：
Public Sub QBR_Deck()
'#
'# Set reference to 'Microsoft PowerPoint <current version> Object Library' in the VBE via Tools > References...
'#
'#
'# Declare variables
'#
Dim app_PowerPoint As PowerPoint.Application
Dim ppt_Presentation As PowerPoint.Presentation
Dim obj_PPTSlide As PowerPoint.Slide
Dim obj_PPTShape As PowerPoint.Shape
Dim obj_ExcelChart As Chart
Dim obj_ExcelWorksheet As Worksheet
Dim obj_ExcelObject As ListObject
Dim lng_i As Long
Dim shp_i As Long
Dim var_Parameters As Variant
Dim str_PPTTemplatePath As String
'#
'# Allow user to select PPT template
'# Set path to same location as spreadsheet
'#
str_PPTTemplatePath = Application.GetOpenFilename(Title:="PowerPoint Template")
If str_PPTTemplatePath = "False" Then Exit Sub
'#
'# Get the PowerPoint Application object
'#
Set app_PowerPoint = CreateObject("PowerPoint.Application")
app_PowerPoint.Visible = msoTrue
Set ppt_Presentation = app_PowerPoint.Presentations.Open(str_PPTTemplatePath, untitled:=msoTrue)
'#
'# Review each slide and each shape on slide
'#
For Each obj_PPTSlide In ppt_Presentation.Slides
For shp_i = obj_PPTSlide.Shapes.Count To 1 Step -1
Set obj_PPTShape = obj_PPTSlide.Shapes(shp_i)
'#
'# Determine when target shapes are located
'# Examine Alternative Text in PPT
'# Text for objects, will be in this format: @REPLACE|XLS_<chart_name>|PPT_<shape_Name>
'#
If Left$(obj_PPTShape.AlternativeText, 8) = "@REPLACE" Then
var_Parameters = Split(obj_PPTShape.AlternativeText, "|")
For Each obj_ExcelWorksheet In ActiveWorkbook.Worksheets
'#
'# Look at each chart on each worksheet
'# Use the Alternative Text to match each chart to the appropriate slide
'# Copy and paste onto slide
'#
For lng_i = obj_ExcelWorksheet.ChartObjects.Count To 1 Step -1
If obj_ExcelWorksheet.ChartObjects(lng_i).Name = var_Parameters(1) Then
obj_PPTSlide.Select
Set obj_ExcelChart = obj_ExcelWorksheet.ChartObjects(lng_i).Chart
obj_ExcelChart.ChartArea.Copy
''app_PowerPoint.Activate '''' unnecessary
''obj_PPTShape.Select '''' unnecessary
app_PowerPoint.Windows(1).View.Paste
app_PowerPoint.Windows(1).Selection.ShapeRange.Left = obj_PPTShape.Left
app_PowerPoint.Windows(1).Selection.ShapeRange.Top = obj_PPTShape.Top
app_PowerPoint.Windows(1).Selection.ShapeRange.Height = obj_PPTShape.Height
app_PowerPoint.Windows(1).Selection.ShapeRange.Width = obj_PPTShape.Width
obj_PPTShape.Delete
Exit For
End If
Next lng_i
Next obj_ExcelWorksheet
End If 'Alternative Text not in expected format
Next shp_i
Next obj_PPTSlide
'#
'# Clean up on the way out
'#
Set ppt_Presentation = Nothing
Set app_PowerPoint = Nothing
End Sub
当我这样做时，我经常在Excel中的工作表上使用表格，该表格列出了要复制和粘贴的每个项目：来源（工作表名称和图表名称或范围地址），目标（幻灯片编号，形状名称或简单的位置和大小参数），幻灯片标题，如果需要，等等。我发现将所有信息保存在一个地方，Excel工作簿更容易，而不是必须进入PowerPoint和muck与Alt文本（你没有'甚至使用PowerPoint形状名称，只能通过VBA访问。虽然我从未使用过Alt文本，但也许这比我努力的方式更容易。