Question

我之前做过这个子程序，因为我对Excel的图表自动缩放不满意。内置的Excel方法在某种程度上起作用，但是当图表数据的范围变得更宽时，它只是将最小比例设置为0，这可能导致非常挤压的线条，其下方有大量空白区域。如下......

Inappropriately scaled Chart

我编写的代码试图通过根据图表中的数据为y轴选择合适的最大和最小限制来改进excel的方法。它工作正常，但有时选择不是最好的值。以下是我的代码应用于同一图表的结果：

Inappropriately scaled Chart

这里它适合绘图区域中的所有数据，因此可以很清楚地看到它所选择的值并不是最好的。人类可以查看这些数据并快速评估90和140可能是本示例中使用的最佳限制，但我在编写脚本时也遇到了相同的问题。

这是整个子。这不是太长。我很感激任何改进限制计算的建议......

Sub ScaleCharts()
'
' ScaleCharts Macro
'
Dim objCht As ChartObject
Dim maxi As Double, mini As Double, Range As Double, Adj As Double, xMax As Double, xMin As Double
Dim Round As Integer, Order As Integer, x As Integer, i As Integer

Application.ScreenUpdating = False
For x = 1 To ActiveWorkbook.Sheets.Count
Application.StatusBar = "Crunching sheet " & x & " of " & ActiveWorkbook.Sheets.Count

For Each objCht In Sheets(x).ChartObjects
  If objCht.Chart.ChartType = xlLine Or objCht.Chart.ChartType = xlXYScatter Then
  With objCht.Chart
  For i = 0 To .SeriesCollection.Count - 1 'Loop through all the series in the chart

            'Get the Max and Min values of the data in the chart
            maxi = Application.max(.SeriesCollection(i + 1).Values)
            mini = Application.min(.SeriesCollection(i + 1).Values)
            Range = maxi - mini

            If Range > 1 Then
                Order = Len(Int(Range))
                Adj = 10 ^ (Order - 2)
                Round = -1 * (Order - 1)
            ElseIf Range <> 0 Then
                Order = Len(Int(1 / Range))
                Adj = 10 ^ (-1 * Order)
                Round = Order - 1
            End If

            'Get the Max and Min values for the axis based on the data
            If i = 0 Or WorksheetFunction.Round(maxi, Round + 1) + Adj > xMax Then
            xMax = WorksheetFunction.Round(maxi, Round + 1) + Adj
            End If

            If i = 0 Or WorksheetFunction.Round(mini, Round + 1) - Adj < xMin Then
            xMin = WorksheetFunction.Round(mini, Round + 1) - Adj
            End If

       Next i

     With .Axes(xlValue)
        .MaximumScale = xMax
        .MinimumScale = xMin
     End With
  End With
  End If
Next objCht
Next x
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

编辑：以下是qPCR4vir变化的结果......

Before

After

最后2个图表因为不超过-100而被切断

Answer 1

你能测试吗？：

Adj = 10 ^ (Order - 1)

和

xMax = WorksheetFunction.ROUNDDOWN(maxi + Adj, Round )
xMin = WorksheetFunction.ROUNDDOWN(mini , Round )

取代：

Adj = 10 ^ (Order - 2)

和

xMax = WorksheetFunction.Round(maxi, Round + 1) + Adj

和

xMin = WorksheetFunction.Round(mini, Round + 1) - Adj

编辑：对于neg nummbers，ROUNDDOWN不正确？我们可以使用ROUND

对其进行建模

xMax = WorksheetFunction.Round(maxi + Adj/2, Round )
xMin = WorksheetFunction.Round(mini - Adj/2, Round )

Answer 2

好的我还有另外一个人使用Vicky建议的MajorUnit属性

Sub ScaleCharts3()
'
' ScaleCharts Macro
'
   Call revertCharts 'A macro that resets the charts to excel auto beforehand - this is so we get the correct "MajorUnit" value

   Dim objCht As ChartObject
   Dim maxi As Double, mini As Double, tryxMax As Double, tryxMin As Double, xMax As Double, xMin As Double, maju As Double
   Dim x As Integer, i As Integer

   Application.ScreenUpdating = False
   For x = 1 To ActiveWorkbook.Sheets.Count
   Application.StatusBar = "Crunching sheet " & x & " of " & ActiveWorkbook.Sheets.Count

   For Each objCht In Sheets(x).ChartObjects
      If objCht.Chart.ChartType = xlLine Or objCht.Chart.ChartType = xlXYScatter Then
      With objCht.Chart
      maju = .Axes(xlValue).MajorUnit
      For i = 0 To .SeriesCollection.Count - 1 'Loop through all the series in the chart

                'Get the Max and Min values of the data in the chart
                maxi = Application.max(.SeriesCollection(i + 1).Values)
                mini = Application.min(.SeriesCollection(i + 1).Values)

                'Get the Max and Min values for the axis based on the data
                tryxMax = roundToMult(maxi, maju)
                tryxMin = roundToMult(mini, maju, False)


                If i = 0 Or tryxMax > xMax Then
                xMax = tryxMax
                End If
                If i = 0 Or tryxMin < xMin Then
                xMin = tryxMin
                End If

           Next i

         With .Axes(xlValue)
            .MaximumScale = xMax
            .MinimumScale = xMin
         End With
      End With
      End If
   Next objCht
   Next x
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

我们还需要一个函数，它将相应地向上和向下舍入到最接近的倍数，如上所述。

Function roundToMult(numToRound As Double, multiple As Double, Optional up As Boolean = True)
numToRound = Int(numToRound)
multiple = Int(multiple)

If multiple = 0 Then
roundToMult = 0
Exit Function
End If

remainder = numToRound Mod multiple
If remainder = 0 Then
roundToMult = numToRound
Else
    If up = True Then
        roundToMult = (numToRound + multiple - remainder)
    Else
        If numToRound < 0 Then
            remainder = multiple + remainder
        End If
        roundToMult = (numToRound - remainder)
    End If
End If
End Function

使用小数字（＆lt; 1）时不会产生任何影响，但Excel通常会在此自动缩放。这也在负面和混合的负/ pos图表数据上进行了测试，似乎也有效。

Answer 3

使用Excel计算的想法：MajorUnit很好（假设总是非常严格!!需要证明）。现在你要找的圆函数是：

tryxMax = Sgn(maxi) * WorksheetFunction.MRound(Abs(maxi + maju / 2.001), maju)
tryxMin = Sgn(mini) * WorksheetFunction.MRound(Abs(mini - maju / 2.001), maju)

适用于所有数字，包括小数或负数。

Answer 4

当你说90和140是最佳值时，你用作人类的算法是什么？

就个人而言，我会查看Excel默认选择的轴分区，并选择最接近数据本身的分区。在你的例子中，这将给你80和140。

Excel将此称为Axis对象的“MajorUnit”属性。

Answer 5

这是我使用的方法： Calculate Nice Axis Scales in Excel VBA

改进算法以根据图表数据适当地缩放图表轴限制

5 个答案: