Search code examples
excelvbapowerpoint

How do I cycle through each chart in a given presentation and adjust its Y axis.?

I have to cycle through each chart in a given presentation and adjust its Y axis.

I copied code from the internet and adjusted it.

  1. The code was programmed for Excel.
    What changes do I make so it can run in PowerPoint?
  2. In Excel, I have 17 charts with similar titles in the active sheet.
    Some charts are adjusted, while some stay as they were.
Sub Chartaxes()

Dim cht As ChartObject
Dim srs As Series
Dim FirstTime  As Boolean
Dim MaxNumber As Double
Dim MinNumber As Double
Dim MaxChartNumber As Double
Dim MinChartNumber As Double
Dim Padding As Double

'Input Padding on Top of Min/Max Numbers (Percentage)
  Padding = 0.1  'Number between 0-1

'Optimize Code
  Application.ScreenUpdating = False
  
'Loop Through Each Chart On ActiveSheet
  For Each cht In ActiveSheet.ChartObjects
    
    'First Time Looking at This Chart?
      FirstTime = True
      
    'Determine Chart's Overall Max/Min From Connected Data Source
      For Each srs In cht.Chart.SeriesCollection
        'Determine Maximum value in Series
          MaxNumber = Application.WorksheetFunction.Max(srs.Values)
        
        'Store value if currently the overall Maximum Value
          If FirstTime = True Then
            MaxChartNumber = MaxNumber
          ElseIf MaxNumber > MaxChartNumber Then
            MaxChartNumber = MaxNumber
          End If
        
        'Determine Minimum value in Series (exclude zeroes)
          MinNumber = Application.WorksheetFunction.Min(srs.Values)
          
        'First Time Looking at This Chart?
          FirstTime = False
      Next srs
      
    'Rescale Y-Axis
      cht.Chart.Axes(xlValue).MinimumScale = 0
      cht.Chart.Axes(xlValue).MaximumScale = MaxChartNumber * (1 + Padding)
  
  Next cht

'Optimize Code
  Application.ScreenUpdating = True

End Sub

Images for reference:

One of the slides

Linked data (an excel file)

Solution

  • Please, try the next adapted version, able to work in Outlook. VBA Outlook does not have Min, Max functions and I built them, too:

    Sub ModffCharts()
    Dim sh As Shape, ch As Chart, srs, Padding As Double, FirstTime As Boolean
    Dim MaxChartNumber As Double, MaxNumber As Double, MinNumber As Double
    
    Padding = 0.1
    For Each sh In Application.ActiveWindow.View.Slide.Shapes 'shapes of the active slide...
        If sh.HasChart = msoTrue Then

            Set ch = sh.Chart
            FirstTime = True
            'Debug.Print ch.SeriesCollection.Count
            For Each srs In ch.SeriesCollection
               'Determine Maximum value in Series
               MaxNumber = MaX(srs.Values)               
                'Store value if currently the overall Maximum Value
                  If FirstTime = True Then
                        MaxChartNumber = MaxNumber
                  ElseIf MaxNumber > MaxChartNumber Then
                        MaxChartNumber = MaxNumber
                  End If
                
                'Determine Minimum value in Series
                  MinNumber = MiN(srs.Values)
                  
                'First Time Looking at This Chart?
                 FirstTime = False
            Next srs
            ch.Axes(xlValue).MinimumScale = 0
            ch.Axes(xlValue).MaximumScale = MaxChartNumber * (1 + Padding)
        End If
   Next sh
End Sub

Function MaX(arr) As Double
    Dim i As Long, Mx As Double
    For i = LBound(arr) To UBound(arr)
       If arr(i) > Mx Then Mx = arr(i)
    Next i
    MaX = Mx
End Function
Function MiN(arr) As Double
    Dim i As Long, Mn As Double
    Mn = MaX(arr)
    For i = LBound(arr) To UBound(arr)
        If arr(i) < Mn Then Mn = arr(i)
    Next i
    MiN = Mn
End Function

    Please, test it and send some feedback.

    Edited:

    Please, test the updated version. It will use the same maximum scale for first three chart, calculate it for the fourth and use it for rest of charts:

    Sub ModffCharts_bis()
    Dim sh As Shape, ch As Chart, srs, Padding As Double, FirstTime As Boolean
    Dim MaxChartNumber As Double, MaxNumber As Double, MinNumber As Double
    Dim i As Long
    
    Padding = 0.1
    FirstTime = True
    For Each sh In Application.ActiveWindow.View.Slide.Shapes
        If sh.HasChart = msoTrue Then
            Set ch = sh.Chart
            i = i + 1
            Select Case i
                Case 2, 3: GoTo OverCalculation
                Case Is > 4: GoTo OverCalculation
            End Select
            
            'Debug.Print ch.SeriesCollection.Count
            For Each srs In ch.SeriesCollection
               'Determine Maximum value in Series
               MaxNumber = MaX(srs.Values)
        
                'Store value if currently the overall Maximum Value
                  If FirstTime = True Then
                        MaxChartNumber = MaxNumber
                  ElseIf MaxNumber > MaxChartNumber Then
                        MaxChartNumber = MaxNumber
                  End If
                
                'Determine Minimum value in Series
                  MinNumber = MiN(srs.Values)
                  
                'First Time Looking at This Chart?
                  FirstTime = False
            Next srs
OverCalculation:
            ch.Axes(xlValue).MinimumScale = 0
            ch.Axes(xlValue).MaximumScale = MaxChartNumber * (1 + Padding)
        End If
   Next sh
End Sub