|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
不适用于折线图等
Sub ScalePlot()
On Error Resume Next
Rem ---- 修正图表绘图区为最大方正化
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
Rem ---- 遍历所有系列确定MinX,MinY,MaxX,MaxY
With Cht
For i = 1 To Cht.SeriesCollection.Count
Set Ser = Cht.SeriesCollection(i)
XVals = Ser.XValues
YVals = Ser.Values
If i = 1 Then
MinX = Application.Min(XVals)
MaxX = Application.Max(XVals)
MinY = Application.Min(YVals)
MaxY = Application.Max(YVals)
Else
MinX = Application.Min(MinX, XVals)
MaxX = Application.Max(MaxX, XVals)
MinY = Application.Min(MinY, YVals)
MaxY = Application.Max(MaxY, YVals)
End If
Next
Rem ---- 最大化绘图区域并获取其尺寸
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)
Rem ---- X和Y值的范围
XDiff = MaxX - MinX
YDiff = MaxY - MinY
Rem ---- 对XDiff和YDiff设置10%的缓冲空间,以便在系列边缘和绘图区之间有空白
Buffer = 0.1
Rem ---- 调整Max/MinX/Y的值
MaxX = MaxX + Buffer * XDiff
MinX = MinX - Buffer * XDiff
MaxY = MaxY + Buffer * YDiff
MinY = MinY - Buffer * YDiff
Rem ---- 修正X和Y值的范围
XDiff = MaxX - MinX
YDiff = MaxY - MinY
Rem ---- 重新缩放坐标轴以获得最大可能的放大倍率
With AxX
.MaximumScale = MaxX
.MinimumScale = MinX
End With
With AxY
.MaximumScale = MaxY
.MinimumScale = MinY
End With
Rem ----计算绘图区单位X和Y的比例
WdScale = PWd1 / XDiff
HtScale = PHt1 / YDiff
If WdScale > HtScale Then
Rem ----X轴需要调整
Rem ----保持Y轴比例不变
XDiff1 = (XDiff * WdScale / HtScale - XDiff) / 2
AxX.MinimumScale = MinX - XDiff1
AxX.MaximumScale = MaxX + XDiff1
Else
Rem ----Y轴需要调整
Rem ----保持X轴比例不变
YDiff1 = (YDiff * HtScale / WdScale - YDiff) / 2
AxY.MinimumScale = MinY - YDiff1
AxY.MaximumScale = MaxY + YDiff1
End If
End With
End Sub
|
|