修改Excel VBA代码适配PowerPoint及解决Excel图表Y轴调整不全问题

一、适配PowerPoint的VBA代码修改 #

原Excel VBA依赖Excel专属的ChartObject对象模型，PowerPoint中图表以Shape形式嵌入幻灯片，需调整遍历逻辑与对象引用，修改后的可运行代码如下：

Sub AdjustPPTChartYAxis()
    Dim sld As Slide
    Dim shp As Shape
    Dim srs As Series
    Dim FirstTime As Boolean
    Dim MaxNumber As Double
    Dim MaxChartNumber As Double
    Dim Padding As Double
    
    ' 顶部留白比例（取值0-1）
    Padding = 0.1
    
    ' 关闭屏幕刷新提升运行效率
    Application.ScreenUpdating = False
    
    ' 遍历当前演示文稿的所有幻灯片
    For Each sld In ActivePresentation.Slides
        ' 遍历幻灯片内所有形状
        For Each shp In sld.Shapes
            ' 筛选出图表类型的形状
            If shp.Type = msoChart Then
                FirstTime = True
                MaxChartNumber = 0
                
                ' 遍历图表的所有数据系列
                For Each srs In shp.Chart.SeriesCollection
                    ' 跳过无有效数据的系列
                    If Not IsEmpty(srs.Values) Then
                        MaxNumber = Application.WorksheetFunction.Max(srs.Values)
                        
                        ' 更新图表全局最大值
                        If FirstTime Then
                            MaxChartNumber = MaxNumber
                            FirstTime = False
                        ElseIf MaxNumber > MaxChartNumber Then
                            MaxChartNumber = MaxNumber
                        End If
                    End If
                Next srs
                
                ' 调整Y轴：最小值固定为0，最大值按留白比例放大
                With shp.Chart.Axes(xlValue)
                    .MinimumScale = 0
                    ' 处理全0数据的特殊情况，避免Y轴无变化
                    .MaximumScale = IIf(MaxChartNumber = 0, 1, MaxChartNumber * (1 + Padding))
                End With
            End If
        Next shp
    Next sld
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
End Sub

修改核心说明： #

• 替换Excel的ChartObject为PowerPoint的Shape，通过shp.Type = msoChart精准筛选图表
• 遍历范围改为ActivePresentation.Slides，覆盖当前演示文稿所有幻灯片
• 增加空数据系列判断，避免运行时错误
• 补充全0数据的特殊处理，防止Y轴无变化

二、Excel中部分图表Y轴未调整的解决方案 #

可能原因及修复方案： #

1. 代码仅处理嵌入式图表，遗漏独立图表工作表
   原代码只遍历ActiveSheet.ChartObjects（嵌入式图表），若存在独立图表工作表（单独的图表标签），需补充遍历逻辑：

   ' 在原嵌入式图表循环后添加以下代码：
   Dim chtSheet As Chart
   For Each chtSheet In ThisWorkbook.Charts
       FirstTime = True
       MaxChartNumber = 0
       ' 复用原系列遍历与最大值计算逻辑
       For Each srs In chtSheet.SeriesCollection
           ' 错误捕获+空值判断（同下方修复逻辑）
           On Error Resume Next
           MaxNumber = Application.WorksheetFunction.Max(srs.Values)
           If Err.Number <> 0 Then
               MaxNumber = 0
               Err.Clear
           End If
           On Error GoTo 0
           
           If Not IsEmpty(srs.Values) Then
               If FirstTime Then
                   MaxChartNumber = MaxNumber
                   FirstTime = False
               ElseIf MaxNumber > MaxChartNumber Then
                   MaxChartNumber = MaxNumber
               End If
           End If
       Next srs
       ' 调整Y轴（仅处理线性数值轴）
       With chtSheet.Axes(xlValue)
           If .AxisType = xlValue And .ScaleType = xlLinear Then
               .MinimumScale = 0
               .MaximumScale = IIf(MaxChartNumber = 0, 1, MaxChartNumber * (1 + Padding))
           End If
       End With
   Next chtSheet
   

2. 部分图表存在空/无效数据系列
   原代码未处理空数据或错误值系列，导致Max函数出错后跳过该图表，需添加错误捕获：

   ' 在计算MaxNumber时插入以下代码：
   On Error Resume Next
   MaxNumber = Application.WorksheetFunction.Max(srs.Values)
   If Err.Number <> 0 Then
       MaxNumber = 0
       Err.Clear
   End If
   On Error GoTo 0
   

3. Y轴为对数刻度或非数值轴
   添加判断确保仅调整线性数值轴：

   With cht.Chart.Axes(xlValue)
       If .AxisType = xlValue And .ScaleType = xlLinear Then
           .MinimumScale = 0
           .MaximumScale = IIf(MaxChartNumber = 0, 1, MaxChartNumber * (1 + Padding))
       End If
   End With
   

4. 最大值初始化逻辑漏洞
   需确保每个图表循环时重置MaxChartNumber，避免继承上一个图表的最大值：

   For Each cht In ActiveSheet.ChartObjects
       FirstTime = True
       MaxChartNumber = 0 ' 重置最大值
       ' 后续系列遍历与调整逻辑
   Next cht
   

修复后的完整Excel代码： #

Sub AdjustExcelChartYAxis()
    Dim cht As ChartObject
    Dim chtSheet As Chart
    Dim srs As Series
    Dim FirstTime As Boolean
    Dim MaxNumber As Double
    Dim MaxChartNumber As Double
    Dim Padding As Double
    
    ' 顶部留白比例（取值0-1）
    Padding = 0.1
    
    ' 关闭屏幕刷新提升效率
    Application.ScreenUpdating = False
    
    ' 遍历当前工作表的嵌入式图表
    For Each cht In ActiveSheet.ChartObjects
        FirstTime = True
        MaxChartNumber = 0
        
        For Each srs In cht.Chart.SeriesCollection
            ' 捕获错误，处理空/无效数据系列
            On Error Resume Next
            MaxNumber = Application.WorksheetFunction.Max(srs.Values)
            If Err.Number <> 0 Then
                MaxNumber = 0
                Err.Clear
            End If
            On Error GoTo 0
            
            If Not IsEmpty(srs.Values) Then
                If FirstTime Then
                    MaxChartNumber = MaxNumber
                    FirstTime = False
                ElseIf MaxNumber > MaxChartNumber Then
                    MaxChartNumber = MaxNumber
                End If
            End If
        Next srs
        
        ' 调整Y轴（仅处理线性数值轴）
        With cht.Chart.Axes(xlValue)
            If .AxisType = xlValue And .ScaleType = xlLinear Then
                .MinimumScale = 0
                .MaximumScale = IIf(MaxChartNumber = 0, 1, MaxChartNumber * (1 + Padding))
            End If
        End With
    Next cht
    
    ' 遍历工作簿中的独立图表工作表
    For Each chtSheet In ThisWorkbook.Charts
        FirstTime = True
        MaxChartNumber = 0
        
        For Each srs In chtSheet.SeriesCollection
            On Error Resume Next
            MaxNumber = Application.WorksheetFunction.Max(srs.Values)
            If Err.Number <> 0 Then
                MaxNumber = 0
                Err.Clear
            End If
            On Error GoTo 0
            
            If Not IsEmpty(srs.Values) Then
                If FirstTime Then
                    MaxChartNumber = MaxNumber
                    FirstTime = False
                ElseIf MaxNumber > MaxChartNumber Then
                    MaxChartNumber = MaxNumber
                End If
            End If
        Next srs
        
        With chtSheet.Axes(xlValue)
            If .AxisType = xlValue And .ScaleType = xlLinear Then
                .MinimumScale = 0
                .MaximumScale = IIf(MaxChartNumber = 0, 1, MaxChartNumber * (1 + Padding))
            End If
        End With
    Next chtSheet
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
End Sub

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