需求：将Excel图表按指定幻灯片号导出至PowerPoint

本人并非VBA专家，之前试过的方案都适配不了我的实际场景，特此求助。现有一段VBA代码可实现将Excel中的图表复制到PowerPoint：如果PowerPoint已打开则激活，未打开则新建实例，之后自动添加幻灯片并粘贴图表。但我需要实现从Excel表格读取指定幻灯片号，将对应图表粘贴到PowerPoint的指定幻灯片的功能，原代码单独运行正常，但添加指定幻灯片号的逻辑后无法正常工作。

原代码如下：

Sub CreatePowerPointWithChart()'

   'First we declare the variables we will be using
       Dim newPowerPoint As PowerPoint.Application
       Dim pre As PowerPoint.Presentations
       Dim Sld As PowerPoint.Slide
       Dim cht As Excel.ChartObject
       Dim SlideNumber As Long
       

    'Look for existing instance
       On Error Resume Next
       Set newPowerPoint = GetObject(, "PowerPoint.Application")
       On Error GoTo 0

   'Let's create a new PowerPoint
       If newPowerPoint Is Nothing Then
           Set newPowerPoint = New PowerPoint.Application
       End If
   'Make a presentation in PowerPoint
       If newPowerPoint.Presentations.Count = 0 Then
           newPowerPoint.Presentations.Add
       End If

   'Show the PowerPoint
       newPowerPoint.Visible = True
       

   'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
       For Each cht In ActiveSheet.ChartObjects

       'Add a new slide where we will paste the chart
           newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly
           newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
           Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

       'Copy the chart and paste it into the PowerPoint as a Metafile Picture
           cht.Select
           ActiveChart.ChartArea.Copy
           activeSlide.Shapes.PasteSpecial(DataType:=ppPasteShape).Select

       'Set the title of the slide the same as the title of the chart
           activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.chart.ChartTitle.Text

       'Adjust the positioning of the Chart on Powerpoint Slide
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = Range("D11").Value
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = Range("E11").Value
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = Range("F11").Value
           newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = Range("G11").Value

        'To Adjust Shapes
            ' activeSlide.Shapes(2).Delete
           ' activeSlide.Shapes(2).Left = 505
           ' activeSlide.Shapes(2).Height = 400

       Next

   Set activeSlide = Nothing
   Set newPowerPoint = Nothing

End Sub

以下是实现从表格读取指定幻灯片号并粘贴图表的代码，同时修复了原代码中依赖Select/Active导致的稳定性问题：

Sub PasteChartToSpecifiedSlide()
    ' 声明变量
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim targetSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject
    Dim slideNum As Long
    Dim ws As Worksheet
    
    ' 指定存放图表对应幻灯片号的工作表（根据你的实际表格位置修改）
    Set ws = ActiveSheet
    
    ' 查找已打开的PowerPoint实例
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    
    ' 若没有运行的PowerPoint实例，则新建
    If pptApp Is Nothing Then
        Set pptApp = New PowerPoint.Application
    End If
    pptApp.Visible = True
    
    ' 确保有打开的演示文稿，无则新建
    If pptApp.Presentations.Count = 0 Then
        Set pptPres = pptApp.Presentations.Add
    Else
        Set pptPres = pptApp.ActivePresentation
    End If
    
    ' 遍历当前工作表中的所有图表
    For Each cht In ws.ChartObjects
        ' 从表格读取该图表对应的目标幻灯片号
        ' 示例规则：A列是图表名称，B列是对应幻灯片号，根据你的表格结构修改范围
        slideNum = Application.VLookup(cht.Name, ws.Range("A:B"), 2, False)
        
        ' 检查指定编号的幻灯片是否存在
        On Error Resume Next
        Set targetSlide = pptPres.Slides(slideNum)
        On Error GoTo 0
        
        ' 若幻灯片不存在，在指定位置新建幻灯片
        If targetSlide Is Nothing Then
            Set targetSlide = pptPres.Slides.Add(slideNum, ppLayoutTitleOnly)
        End If
        
        ' 复制图表并粘贴到目标幻灯片
        cht.Chart.ChartArea.Copy
        targetSlide.Shapes.PasteSpecial DataType:=ppPasteShape
        
        ' 设置幻灯片标题为图表标题（仅当图表有标题时生效）
        If cht.Chart.HasTitle Then
            targetSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
        End If
        
        ' 调整图表的位置和尺寸（读取D11:G11的配置值，可按需修改）
        With targetSlide.Shapes(targetSlide.Shapes.Count)
            .Left = ws.Range("D11").Value
            .Top = ws.Range("E11").Value
            .Width = ws.Range("F11").Value
            .Height = ws.Range("G11").Value
        End With
        
        Set targetSlide = Nothing
    Next cht
    
    ' 释放对象，避免内存泄漏
    Set pptPres = Nothing
    Set pptApp = Nothing
    Set ws = Nothing
End Sub

关键配置与说明 #

• 表格设置：确保你的Excel表格中，A列存储图表的名称（需与Excel里图表对象的名称完全一致），B列存储该图表要粘贴到的PowerPoint幻灯片号。如果你的表格结构不同，修改ws.Range("A:B")和VLookup的参数即可。
• 幻灯片处理：如果指定的幻灯片号不存在，代码会自动在该编号位置新建幻灯片；若已存在，则直接在该幻灯片上粘贴图表（若需要替换原有内容，可添加targetSlide.Shapes.Delete语句清空幻灯片后再粘贴）。
• 引用库要求：打开Excel VBA编辑器后，点击「工具」→「引用」，勾选「Microsoft PowerPoint xx.x Object Library」（xx.x对应你的Office版本），否则代码会报错。
• 稳定性优化：移除了原代码中的Select/Active操作，改用对象直接引用，避免因窗口焦点变化导致的运行错误。

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