如何将图表网格线间距设置成正方形

Finstar

如上图所示，为了使图形不向右图那样失真
希望能将X,Y轴网格间距约束成等距，如左图红框为正方形

我目前是手动拉伸，近视为正方形
能否设置成正方形，拉伸图形等比放大？

还请大侠指导，谢谢了！

木槿花西月锦绣

写代码

wb_1027

不适用于折线图等

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

Finstar

wb_1027 发表于 2024-7-18 21:51
不适用于折线图等

Sub ScalePlot()

谢谢大侠，成功约束成等距了。
另外，能否把网格坐标圆整成个位数为0或5的整数？

wb_1027

Finstar 发表于 2024-7-19 09:22
谢谢大侠，成功约束成等距了。
另外，能否把网格坐标圆整成个位数为0或5的整数？

这个其实没什么必要使用代码，手动调一下就行了，，，

Finstar

wb_1027 发表于 2024-7-19 10:54
这个其实没什么必要使用代码，手动调一下就行了，，，

好的，谢谢大侠！