将选择的Excel图表复制到PowerPoint中的位置

Question

从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

Answer 1

Office 2016 Pro Plus，Windows 10（不是Office 365，但无关紧要）。

我注意到当您For Each obj_PPTShape In obj_PPTSlide.Shapes使用For Each obj_PPTShape In obj_PPTSlide.Shapes并删除形状时，它会破坏循环。 第二次通过循环，它仍在考虑已删除的第一个形状。

因此，我引入了一个形状计数器，并从obj_PPTSlide.Shapes.Count开始obj_PPTSlide.Shapes.Count工作（您实际上并不需要与Excel幻灯片上的图表（顺便说一句）做）。 在删除形状之后，我还立即插入了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并使用Alt文本进行处理（而且您甚至都没有使用PowerPoint形状名称，只能通过VBA访问）。 尽管我从未使用过Alt文本，但是这也许比我奋斗的过程更容易。