求助：提取PowerPoint图表最值的VBA代码调试

原代码存在的问题 #

• 重复初始化PowerPoint应用对象，冗余且可能引发异常
• 错误使用未定义的ChartObject对象，应通过遍历的Shape对象直接访问其Chart属性
• Range(oRow, "B")语法错误，Excel的Range方法不支持「行号+列标字符串」的参数组合，改用Cells(oRow, "B")更准确
• 重复执行oRow = oRow + 1，且遇到首个图表就Exit For，导致每张幻灯片仅处理第一个图表，遗漏其他图表
• 未处理坐标轴为自动刻度的场景，直接读取MaximumScale/MinimumScale会触发运行时错误

修正后的完整代码 #

Sub CopySlideChartAxesScales()
    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape
    Dim oRow As Long
    Dim ws As Worksheet
    
    ' 初始化Excel工作表对象，简化后续引用
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    oRow = 6 ' 起始行
    
    ' 初始化PowerPoint应用（二选一即可，推荐New方式，需先引用PowerPoint对象库）
    ' 若未引用对象库，改用Set ppApp = CreateObject("PowerPoint.Application")
    Set ppApp = New PowerPoint.Application
    ppApp.Visible = msoTrue
    
    ' 获取PPT文件路径
    Dim inputPath As String
    inputPath = ws.Range("B1").Value
    If inputPath = "" Then
        MsgBox "请在Sheet1的B1单元格填写PPT文件路径！"
        ppApp.Quit
        Set ppApp = Nothing
        Exit Sub
    End If
    
    ' 打开PPT文件
    On Error Resume Next
    Set ppPres = ppApp.Presentations.Open(inputPath)
    On Error GoTo 0
    If ppPres Is Nothing Then
        MsgBox "无法打开指定路径的PPT文件，请检查路径是否正确！"
        ppApp.Quit
        Set ppApp = Nothing
        Exit Sub
    End If
    
    ' 遍历每张幻灯片
    For Each ppSlide In ppPres.Slides
        ' 遍历幻灯片上的所有形状
        For Each ppShape In ppSlide.Shapes
            ' 判断是否为图表
            If ppShape.HasChart Then
                With ppShape.Chart
                    ' 写入幻灯片编号和图表名称，方便定位
                    ws.Cells(oRow, "A").Value = "幻灯片" & ppSlide.SlideNumber
                    ws.Cells(oRow, "A").HorizontalAlignment = xlLeft
                    ws.Cells(oRow, "B").Value = .Name
                    
                    ' 处理分类轴（X轴）的最值，添加错误处理避免自动刻度报错
                    On Error Resume Next
                    ws.Cells(oRow, "C").Value = .Axes(xlCategory).MaximumScale
                    ws.Cells(oRow, "D").Value = .Axes(xlCategory).MinimumScale
                    If Err.Number <> 0 Then
                        ws.Cells(oRow, "C").Value = "自动刻度"
                        ws.Cells(oRow, "D").Value = "自动刻度"
                        Err.Clear
                    End If
                    On Error GoTo 0
                    
                    ' 处理数值轴（Y轴）的最值，可选添加
                    On Error Resume Next
                    ws.Cells(oRow, "E").Value = .Axes(xlValue).MaximumScale
                    ws.Cells(oRow, "F").Value = .Axes(xlValue).MinimumScale
                    If Err.Number <> 0 Then
                        ws.Cells(oRow, "E").Value = "自动刻度"
                        ws.Cells(oRow, "F").Value = "自动刻度"
                        Err.Clear
                    End If
                    On Error GoTo 0
                End With
                oRow = oRow + 1 ' 每处理一个图表，行号+1
            End If
        Next ppShape
    Next ppSlide
    
    ' 清理对象
    ppPres.Close
    ppApp.Quit
    Set ppShape = Nothing
    Set ppSlide = Nothing
    Set ppPres = Nothing
    Set ppApp = Nothing
    Set ws = Nothing
    
    MsgBox "图表轴值提取完成！"
End Sub

关键修正说明 #

1. 对象引用规范：使用ppShape.Chart直接访问PPT中的图表对象，替代原代码中未定义的ChartObject
2. 错误处理：添加On Error Resume Next捕获自动刻度的异常，避免程序中断，并标记为「自动刻度」
3. 完整遍历：移除Exit For，确保每张幻灯片上的所有图表都被处理
4. 信息补充：添加幻灯片编号和图表名称列，方便后续核对对应图表
5. 资源清理：执行完后关闭PPT并释放所有对象，避免内存泄漏
6. 路径校验：增加路径空值和文件打开失败的判断，提升代码健壮性

使用前准备 #

• 打开VBA编辑器后，点击「工具」→「引用」，勾选Microsoft PowerPoint XX.X Object Library（XX.X为你的Office版本号），若未引用则改用CreateObject方式初始化PowerPoint应用

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