VBA实战技巧22：调整XY图表缩放比例以获取正确的宽高比
excelperfect
目标：想要调整XY（散点图）图表，以使两个轴的单位坐标轴值具有相同的比例。也就是说，需要调整图1中的图表，以便成为如图2所示的正方形和圆形。
图1：开始时是椭圆形和长方形
图2：调整为圆形和正方形
解决方案：
下面的代码可以处理嵌入式图表和图表工作表。在运行代码之前，确保选择了图表或者图表工作表是当前工作表。
Sub ScalePlot()
Dim Cht As Chart, Ser As Series, AxX As Axis, AxY As Axis
Dim XVals, YVals, MinX, MinY, MaxX, MaxY
Dim i
Dim PWd, PHt, PWd1, PHt1
Dim XDiff, YDiff, XDiff1, YDiff1
Dim Buffer
Dim WdScale, HtScale
Set Cht = ActiveChart
With Cht
'遍历所有系列确定MinX,MinY,MaxX,MaxY
For i = 1 To Cht.SeriesCollection.Count
Set Ser = Cht.SeriesCollection(i)
XVals = Ser.XValues
YVals = Ser.Values
If i = 1 Then
MinX = WorksheetFunction.Min(XVals)
MaxX =WorksheetFunction.Max(XVals)
MinY =WorksheetFunction.Min(YVals)
MaxY =WorksheetFunction.Max(YVals)
Else
MinX =WorksheetFunction.Min(MinX, XVals)
MaxX =WorksheetFunction.Max(MaxX, XVals)
MinY =WorksheetFunction.Min(MinY, YVals)
MaxY =WorksheetFunction.Max(MaxY, YVals)
End If
Next
'最大化绘图区域并获取其尺寸
With .PlotArea
.Top = 0
.Left = 0
.Width = Cht.ChartArea.Width
.Height = Cht.ChartArea.Height
PWd = .Width
PHt = .Height
PWd1 = .InsideWidth
PHt1 = .InsideHeight
End With
Set AxX = .Axes(xlCategory)
Set AxY = .Axes(xlValue)
'X和Y值的范围
XDiff = MaxX - MinX
YDiff = MaxY - MinY
'对XDiff和YDiff设置10%的缓冲空间,以便在系列边缘和绘图区之间有空白
Buffer = 0.1
'调整Max/MinX/Y的值
MaxX = MaxX + Buffer * XDiff
MinX = MinX - Buffer * XDiff
MaxY = MaxY + Buffer * YDiff
MinY = MinY - Buffer * YDiff
'修正X和Y值的范围
XDiff = MaxX - MinX
YDiff = MaxY - MinY
'重新缩放坐标轴以获得最大可能的放大倍率
With AxX
.MaximumScale = MaxX
.MinimumScale = MinX
End With
With AxY
.MaximumScale = MaxY
.MinimumScale = MinY
End With
'计算绘图区单位X和Y的比例
WdScale = PWd1 / XDiff
HtScale = PHt1 / YDiff
If WdScale > HtScale Then
'X轴需要调整
'保持Y轴比例不变
XDiff1 = (XDiff * WdScale / HtScale- XDiff) / 2
AxX.MinimumScale = MinX - XDiff1
AxX.MaximumScale = MaxX + XDiff1
Else
'Y轴需要调整
'保持X轴比例不变
YDiff1 = (YDiff * HtScale / WdScale- YDiff) / 2
AxY.MinimumScale = MinY - YDiff1
AxY.MaximumScale = MaxY + YDiff1
End If
End With
End Sub
图2所示的示例图表绘制了一个半径为4的圆，圆心是(5,5)，长为8的正方形，左上角坐标是(4.5,12)。
在x和y数据具有相似数量级的情况下（例如，当绘制形状而不是代数函数时），会出现此问题。通常，创建此类图表时，x和y轴的比例不同。绘图区域的高度和宽度也助于绘制序列的失真程度。这里的想法是确定需要将两个轴中的哪个轴设置为最小/最大比例值的更大范围，以便以正确的宽高比显示系列，也便于计算所需的最小/最大比例值，从而相应地设置坐标轴比例。
下面的代码段遍历图表中所有系列来计算最小/最大的x和y：
For i = 1 To Cht.SeriesCollection.Count
Set Ser = Cht.SeriesCollection(i)
XVals = Ser.XValues
YVals = Ser.Values
If i = 1 Then
MinX = WorksheetFunction.Min(XVals)
MaxX = WorksheetFunction.Max(XVals)
MinY = WorksheetFunction.Min(YVals)
MaxY = WorksheetFunction.Max(YVals)
Else
MinX = WorksheetFunction.Min(MinX,XVals)
MaxX = WorksheetFunction.Max(MaxX,XVals)
MinY = WorksheetFunction.Min(MinY,YVals)
MaxY = WorksheetFunction.Max(MaxY,YVals)
End If
Next
下面的代码将绘图区域最大化到图表边界，并获取绘图区域的内部尺寸（这些尺寸对进行缩放是必需的）：
With .PlotArea
.Top = 0
.Left = 0
.Width = Cht.ChartArea.Width
.Height = Cht.ChartArea.Height
PWd = .Width
PHt = .Height
PWd1 = .InsideWidth
PHt1 = .InsideHeight
End With
下一段代码计算极限x和y值的范围：
'X和Y值的范围
XDiff = MaxX -MinX
YDiff = MaxY -MinY
'对XDiff和YDiff设置10%的缓冲空间,以便在系列边缘和绘图区之间有空白
Buffer = 0.1
'调整Max/MinX/Y的值
MaxX = MaxX +Buffer * XDiff
MinX = MinX -Buffer * XDiff
MaxY = MaxY +Buffer * YDiff
MinY = MinY -Buffer * YDiff
'修正X和Y值的范围
XDiff = MaxX -MinX
YDiff = MaxY -MinY
'重新缩放坐标轴以获得最大可能的放大倍率
With AxX
.MaximumScale = MaxX
.MinimumScale = MinX
End With
With AxY
.MaximumScale= MaxY
.MinimumScale = MinY
End With
将x和y范围的10％的缓冲设置为在绘图区域内适当地容纳该系列，重新计算范围（包括缓冲区），并将轴的最小/最大比例设置为新计算的最小/最大值。
代码的最后一部分针对修改后的x和y范围计算绘图区域内部尺寸的新缩放比例：
'计算绘图区单位X和Y的比例
WdScale = PWd1/ XDiff
HtScale = PHt1/ YDiff
If WdScale> HtScale Then
'X轴需要调整
'保持Y轴比例不变
XDiff1 = (XDiff * WdScale / HtScale -XDiff) / 2
AxX.MinimumScale = MinX - XDiff1
AxX.MaximumScale = MaxX + XDiff1
Else
'Y轴需要调整
'保持X轴比例不变
YDiff1 = (YDiff * HtScale / WdScale -YDiff) / 2
AxY.MinimumScale = MinY - YDiff1
AxY.MaximumScale = MaxY + YDiff1
End If
如果水平缩放比例大于垂直缩放比例，则需要将x轴设置为更大的缩放比例范围（XDiff1），该范围是根据绘图区域内部宽度的水平缩放比例计算得出的。XDiff1对称地应用于x轴缩放比例（即，x轴的最小缩放比例减少XDiff1/2），最大缩放比例增加相同的量。如果垂直缩放比例大于水平缩放比例，则对y轴执行相同的操作。
小结：该解决方案中的代码以编程方式调整了一个散点图，该散点图包含相似数量级系列，以显示正确比例的系列。
注：本文学习整理自mrexcel.com，供有兴趣的朋友参考。