繁体   English   中英

如何修改此 VBA 代码以运行 Powerpoint 演示文稿而不是工作表?

[英]How do I modify this VBA code to run through a Powerpoint presentation instead of a worksheet?

VBA 初学者在这里。 我有这个问题,我必须:循环浏览给定演示文稿中的每个图表,然后调整其 Y 轴 我想自动化这个过程,因为手动浏览每个图表并调整它的轴是乏味的。

因为我是一个菜鸟,所以我不得不从互联网上复制代码并根据我的需要进行调整。 我做了一些小的调整,但无法弄清楚一些事情。

  1. 甚至可以自动化这个过程吗?
  2. 该代码是为 Excel 编写的,无法在 powerpoint 上运行,我要进行哪些更改才能使其无错误运行?
  3. 我需要对代码进行任何其他调整吗?
  4. 每当我在 Excel 上运行此代码时,它都不会遍历活动工作表中的所有图表。 我有 17 个标题相似的图表。 一些图表进行了调整,而另一些则保持原样。 为什么会这样?
    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

如果问题很愚蠢,我很抱歉,如果我不应该在这里发布,请在评论中告诉我。 另外,让我知道是否有更好的方法可以做到这一点。

先感谢您!

请尝试下一个适应版本,能够在Outlook中工作。 VBA Outlook 没有MinMax功能,我也构建了它们:

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
    FirstTime = True
    For Each sh In Application.ActiveWindow.View.Slide.Shapes 'shapes of the active slide...
        If sh.HasChart = msoTrue Then
            Set ch = sh.Chart
            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

请测试它并发送一些反馈。

暂无
暂无

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM