使用VBA批量提取Powerpoint图表数据至Excel工作表求助

原代码存在的问题 #

• 全局使用On Error Resume Next吞掉所有报错，当Excel程序未启动、目标工作簿/工作表不存在时代码会静默失败，无任何提示
• 写死复制范围A2:E10，无法适配不同行列规模的图表数据，会出现数据漏取、取到空白值的问题
• 依赖剪贴板+DataObject读取文本的方式会丢失表格结构，所有内容会挤入单个单元格，还容易触发剪贴板占用、内容为空的异常
• 对象引用冗余：遍历幻灯片和形状时，PPTPres.Slides(PPTSlide).Shapes(PPTShape)属于重复调用，直接使用循环中已赋值的PPTShape对象即可
• 直接将ChartData对象写入单元格，该对象无法直接转为文本值，会触发类型不匹配错误
• 未关闭激活的图表数据工作簿，代码运行后会在后台残留大量隐藏的Excel进程，占用系统资源

前置准备 #

打开VBA编辑器，依次点击「工具-引用」，勾选Microsoft Excel [版本号] Object Library，版本号对应你本机安装的Office主版本即可

修正后可直接运行的代码 #

Sub PowerpointToExcel()
    Dim PPTPres As Presentation
    Dim PPTSlide As Slide
    Dim PPTShape As Shape
    Dim PPTChart As Chart
    
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlWriteStart As Excel.Range
    Dim chartDataWb As Excel.Workbook
    Dim chartDataRng As Excel.Range
    Dim nextWriteRow As Long
    
    Set PPTPres = Application.ActivePresentation

    ' 绑定Excel实例，不存在则新建
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = New Excel.Application
        Err.Clear
    End If
    On Error GoTo 0
    xlApp.Visible = True ' 不需要查看Excel窗口可改为False

    ' 绑定目标工作簿Book2.xlsx，不存在则在PPT同目录下新建
    On Error Resume Next
    Set xlBook = xlApp.Workbooks("Book2.xlsx")
    If Err.Number <> 0 Then
        Set xlBook = xlApp.Workbooks.Add
        xlBook.SaveAs Filename:=PPTPres.Path & "\Book2.xlsx"
        Err.Clear
    End If
    On Error GoTo 0

    ' 绑定目标工作表Sheet2，不存在则新建
    On Error Resume Next
    Set xlSheet = xlBook.Worksheets("Sheet2")
    If Err.Number <> 0 Then
        Set xlSheet = xlBook.Worksheets.Add
        xlSheet.Name = "Sheet2"
        Err.Clear
    End If
    On Error GoTo 0

    ' 首次运行写入表头
    nextWriteRow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(xlUp).Row
    If nextWriteRow = 1 And xlSheet.Range("A1").Value = "" Then
        xlSheet.Range("A1:C1") = Array("图表数据", "所属幻灯片", "所属图表名称")
    End If
    nextWriteRow = nextWriteRow + 1

    ' 遍历所有幻灯片
    For Each PPTSlide In PPTPres.Slides
        ' 遍历幻灯片内所有形状
        For Each PPTShape In PPTSlide.Shapes
            If PPTShape.HasChart Then
                Set PPTChart = PPTShape.Chart
                ' 激活图表对应的数据工作簿
                PPTChart.ChartData.Activate
                Set chartDataWb = PPTChart.ChartData.Workbook
                ' 自动识别数据实际使用范围，跳过数据工作簿自带的表头行
                Set chartDataRng = chartDataWb.Sheets(1).UsedRange
                Set chartDataRng = chartDataRng.Offset(1, 0).Resize(chartDataRng.Rows.Count - 1, chartDataRng.Columns.Count)
                
                ' 将数据粘贴到目标位置，保留行列结构
                Set xlWriteStart = xlSheet.Range("A" & nextWriteRow)
                chartDataRng.Copy
                xlWriteStart.PasteSpecial Paste:=xlPasteValues
                
                ' 写入溯源标识
                xlWriteStart.Offset(0, chartDataRng.Columns.Count).Value = PPTSlide.Name
                xlWriteStart.Offset(0, chartDataRng.Columns.Count + 1).Value = PPTShape.Name
                
                ' 更新下一次写入的行号
                nextWriteRow = nextWriteRow + chartDataRng.Rows.Count
                ' 关闭当前图表的数据工作簿，避免残留后台进程
                chartDataWb.Close SaveChanges:=False
            End If
        Next
    Next

    ' 自动调整列宽
    xlSheet.Columns.AutoFit
    ' 释放对象
    Application.CutCopyMode = False
    Set chartDataRng = Nothing
    Set chartDataWb = Nothing
    Set xlWriteStart = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Set PPTChart = Nothing
    Set PPTShape = Nothing
    Set PPTSlide = Nothing
    Set PPTPres = Nothing

    MsgBox "全部图表数据提取完成", vbInformation
End Sub

代码特性 #

• 自动适配环境：如果目标Excel程序、工作簿、工作表不存在，会自动创建，不会静默失败
• 自适应数据范围：不需要手动指定复制的行列数，自动识别每个图表的实际数据区域
• 保留数据结构：直接按值粘贴多行列数据，不会出现所有内容挤在单个单元格的问题
• 无残留进程：每提取完一个图表就关闭对应的数据工作簿，不会在后台留存隐藏Excel进程
• 溯源方便：每段数据旁会标注所属幻灯片名称、图表名称，方便对应回PPT内的原图表
• 自动排版：提取完成后自动调整列宽，弹出完成提示

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