使Excel图表网格线呈正方形的VBA代码

标签：Excel图表，VBA

Excel在缩放图表轴方面做得相当好，但有时你希望它能做得更好。下图1所示的XY散点图显示了一种情况，所有点的X和Y值都在0和7之间，但由于图表本身是矩形的，因此网格线沿X和Y轴的间距不同。如果沿两个轴的间距相同，并提供正方形网格线，不是更好吗？

图1

有几种方法可以实现这一点，不包括用鼠标单击和拖动的繁琐手动方法，也不包括尝试轴最大值的一系列值。这里使用VBA来处理此任务。

通过更改轴比例来设置方形网格线

第一种方法是测量图表的绘图区域尺寸，锁定轴比例参数，并使用比例确定网格线在水平和垂直方向的距离。然后，具有较大间距的轴的最大值会增加，因此其网格线间距会缩小以匹配较小间距的轴上的间距。

下面的函数接受想要处理的图表，实现正方形网格线。

代码语言：javascript复制

Function SquareGridChangingScale(myChart As Chart)
    With myChart
        '获取绘图区尺寸
        With .PlotArea
            Dim plotInHt As Double
            Dim plotInWd As Double
            plotInHt = .InsideHeight
            plotInWd = .InsideWidth
        End With
        '获取轴比例参数并锁定比例
        With .Axes(xlValue)
            Dim Ymax As Double
            Dim Ymin As Double
            Dim Ymaj As Double
            Ymax = .MaximumScale
            Ymin = .MinimumScale
            Ymaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        With .Axes(xlCategory)
            Dim Xmax As Double
            Dim Xmin As Double
            Dim Xmaj As Double
            Xmax = .MaximumScale
            Xmin = .MinimumScale
            Xmaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        '刻度间距(距离)
        Dim Ytic As Double
        Dim Xtic As Double
        Ytic = plotInHt * Ymaj / (Ymax - Ymin)
        Xtic = plotInWd * Xmaj / (Xmax - Xmin)
        '保持绘图大小不变，调整最大比例
        If Xtic > Ytic Then
            .Axes(xlCategory).MaximumScale =plotInWd * Xmaj / Ytic   Xmin
        Else
            .Axes(xlValue).MaximumScale =plotInHt * Ymaj / Xtic   Ymin
        End If
    End With
End Function

使用下面的代码调用上面的函数过程：

代码语言：javascript复制

SquareGridChangingScale ActiveChart

图表效果如下图2所示，网格线为正方形。

图2

图表中有一条奇怪的空白边，但可以通过格式化绘图区域边框以匹配轴，使其看起来不那么奇怪。

图3

试试另一张图表。与第一个类似，但X值是之前的两倍，这导致了不同的比例，如下图4所示。

图4

调用SquareGridChangingScale过程后的图表如下图5所示。同样，网格线是正方形的，右边缘看起来是空白的。但看到了另一个问题：X轴刻度间距为2个单位，而Y轴的刻度间距为1个单位。

图5

强制主单位间距相等

通过添加可选参数EqualMajorUnit来修改前面的过程。如果该参数设置为True，则在调整轴最大值之前，代码将对两个轴应用相同的间距；如果该参数设置为False或省略，代码将忽略刻度间距。

代码语言：javascript复制

Function SquareGridChangingScale2(myChart As Chart, Optional EqualMajorUnit As Boolean =False)
    With myChart
        '获取绘图区尺寸
        With .PlotArea
            Dim plotInHt As Double
            Dim plotInWd As Double
            plotInHt = .InsideHeight
            plotInWd = .InsideWidth
        End With
        '获取轴比例参数并锁定比例
        With .Axes(xlValue)
            Dim Ymax As Double
            Dim Ymin As Double
            Dim Ymaj As Double
            Ymax = .MaximumScale
            Ymin = .MinimumScale
            Ymaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        With .Axes(xlCategory)
            Dim Xmax As Double
            Dim Xmin As Double
            Dim Xmaj As Double
            Xmax = .MaximumScale
            Xmin = .MinimumScale
            Xmaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        If EqualMajorUnit Then
            '设置刻度间距为相同值
            Xmaj = WorksheetFunction.Min(Xmaj,Ymaj)
            Ymaj = Xmaj
            .Axes(xlCategory).MajorUnit = Xmaj
            .Axes(xlValue).MajorUnit = Ymaj
        End If
        '刻度间距(距离)
        Dim Ytic As Double
        Dim Xtic As Double
        Ytic = plotInHt * Ymaj / (Ymax - Ymin)
        Xtic = plotInWd * Xmaj / (Xmax - Xmin)
        '保持绘图大小不变，调整最大比例
        If Xtic > Ytic Then
            .Axes(xlCategory).MaximumScale =plotInWd * Xmaj / Ytic   Xmin
        Else
            .Axes(xlValue).MaximumScale =plotInHt * Ymaj / Xtic   Ymin
        End If
    End With
End Function

调用上述函数并稍作格式调整后的效果如下图6所示。

图6

通过更改绘图区域大小来设置方形网格线

通过保持绘图区域固定和调整轴比例，实现了上面的方形网格线。但是，如果将绘图区域缩小到网格线成正方形所需的数量，会怎么样？沿着图表的边缘获得空白区域，而不会在空格中挂起一些网格线，然后可以将绘图区域置于图表的中心。

代码语言：javascript复制

Function SquareGridChangingPlotSize(myChart As Chart, Optional EqualMajorUnit As Boolean= False)
    With myChart
        '获取绘图区大小
        With .PlotArea
            Dim plotInHt As Double
            Dim plotInWd As Double
            plotInHt = .InsideHeight
            plotInWd = .InsideWidth
        End With
        '获取轴比例参数并锁定比例
        With .Axes(xlValue)
            Dim Ymax As Double
            Dim Ymin As Double
            Dim Ymaj As Double
            Ymax = .MaximumScale
            Ymin = .MinimumScale
            Ymaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        With .Axes(xlCategory)
            Dim Xmax As Double
            Dim Xmin As Double
            Dim Xmaj As Double
            Xmax = .MaximumScale
            Xmin = .MinimumScale
            Xmaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        If EqualMajorUnit Then
            '设置刻度间距为相同值
            Xmaj = WorksheetFunction.Min(Xmaj,Ymaj)
            Ymaj = Xmaj
            .Axes(xlCategory).MajorUnit = Xmaj
            .Axes(xlValue).MajorUnit = Ymaj
        End If
        '刻度间距(距离)
        Dim Ytic As Double
        Dim Xtic As Double
        Ytic = plotInHt * Ymaj / (Ymax - Ymin)
        Xtic = plotInWd * Xmaj / (Xmax - Xmin)
        '调整绘图区大小,在空间内居中
        If Xtic < Ytic Then
            .PlotArea.InsideHeight =.PlotArea.InsideHeight * Xtic / Ytic
            .PlotArea.Top = .PlotArea.Top   _
                (.ChartArea.Height -.PlotArea.Height - .PlotArea.Top) / 2
        Else
            .PlotArea.InsideWidth =.PlotArea.InsideWidth * Ytic / Xtic
            .PlotArea.Left = .PlotArea.Left   _
                (.ChartArea.Width -.PlotArea.Width - .PlotArea.Left) / 2
        End If
    End With
End Function

调用这段代码时，得到的是正方形网格线，没有延伸的网格线扩展，也没有大的空白区域。绘图区域很好地居中。

图7

对于其他数据的图表，效果如下图8所示。

图8

使用EqualMajorUnit=True，正方形网格在X轴和Y轴上有不同的刻度间距。再试一次，如下图9所示。

图9

通过更改图表大小调整为方形网格

当第二个函数调整绘图区域的大小时，结果图表中出现了一些空白。在某些情况下，此空白会很大。如果缩小整个图表，而不仅仅是绘图区域，并吸收多余的空白，会怎么样？

代码语言：javascript复制

Function SquareGridChangingChartSize(myChart As Chart, Optional EqualMajorUnit AsBoolean = False)
    With myChart
        '获取绘图区大小
        With .PlotArea
            Dim plotInHt As Double
            Dim plotInWd As Double
            plotInHt = .InsideHeight
            plotInWd = .InsideWidth
        End With
        '获取轴比例参数并锁定比例
        With .Axes(xlValue)
            Dim Ymax As Double
            Dim Ymin As Double
            Dim Ymaj As Double
            Ymax = .MaximumScale
            Ymin = .MinimumScale
            Ymaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        With .Axes(xlCategory)
            Dim Xmax As Double
            Dim Xmin As Double
            Dim Xmaj As Double
            Xmax = .MaximumScale
            Xmin = .MinimumScale
            Xmaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        If EqualMajorUnit Then
            '设置刻度间距为相同值
            Xmaj = WorksheetFunction.Min(Xmaj,Ymaj)
            Ymaj = Xmaj
            .Axes(xlCategory).MajorUnit = Xmaj
            .Axes(xlValue).MajorUnit = Ymaj
        End If
        '刻度间距(距离)
        Dim Ytic As Double
        Dim Xtic As Double
        Ytic = plotInHt * Ymaj / (Ymax - Ymin)
        Xtic = plotInWd * Xmaj / (Xmax - Xmin)
        '调整图表大小,在空间内居中
        If Xtic < Ytic Then
            .Parent.Height = .Parent.Height -.PlotArea.InsideHeight * (1 - Xtic / Ytic)
        Else
            .Parent.Width = .Parent.Width -.PlotArea.InsideWidth * (1 - Ytic / Xtic)
        End If
    End With
End Function

应用这种方法时有一些注意事项：调整图表大小时，图表标题可能会决定它需要换行，这将更改绘图区域大小，并使网格线不呈正方形。以下是两个数据集的图表结果，无需修复第二个数据集的刻度间距不匹配。

图10

下图11是第二个数据集在EqualMajorUnit设置为True时的图表效果。

图11

改进该函数的方法是设置参数ShrinkChart，告诉函数是调整绘图区域（如果为False）还是调整图表大小（如果为True）。

代码语言：javascript复制

Function SquareGridChangingChartSize(myChart As Chart, _
    ShrinkChart As Boolean, _
    Optional EqualMajorUnit As Boolean = False)
    With myChart
        '获取绘图区大小
        With .PlotArea
            Dim plotInHt As Double
            Dim plotInWd As Double
            plotInHt = .InsideHeight
            plotInWd = .InsideWidth
        End With
        '获取轴比例参数并锁定比例
        With .Axes(xlValue)
            Dim Ymax As Double
            Dim Ymin As Double
            Dim Ymaj As Double
            Ymax = .MaximumScale
            Ymin = .MinimumScale
            Ymaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        With .Axes(xlCategory)
            Dim Xmax As Double
            Dim Xmin As Double
            Dim Xmaj As Double
            Xmax = .MaximumScale
            Xmin = .MinimumScale
            Xmaj = .MajorUnit
            .MaximumScaleIsAuto = False
            .MinimumScaleIsAuto = False
            .MajorUnitIsAuto = False
        End With
        If EqualMajorUnit Then
            '设置刻度间距为相同值
            Xmaj = WorksheetFunction.Min(Xmaj,Ymaj)
            Ymaj = Xmaj
            .Axes(xlCategory).MajorUnit = Xmaj
            .Axes(xlValue).MajorUnit = Ymaj
        End If
        '刻度间距(距离)
        Dim Ytic As Double
        Dim Xtic As Double
        Ytic = plotInHt * Ymaj / (Ymax - Ymin)
        Xtic = plotInWd * Xmaj / (Xmax - Xmin)
        If ShrinkChart Then
            '调整图表大小
            If Xtic < Ytic Then
                .Parent.Height = .Parent.Height- .PlotArea.InsideHeight * (1 - Xtic / Ytic)
            Else
                .Parent.Width = .Parent.Width -.PlotArea.InsideWidth * (1 - Ytic / Xtic)
            End If
        Else
            '调整绘图区大小,在空间内居中
            If Xtic < Ytic Then
              .PlotArea.InsideHeight =.PlotArea.InsideHeight * Xtic / Ytic
              .PlotArea.Top = .PlotArea.Top   _
                (.ChartArea.Height -.PlotArea.Height - .PlotArea.Top) / 2
            Else
              .PlotArea.InsideWidth =.PlotArea.InsideWidth * Ytic / Xtic
              .PlotArea.Left = .PlotArea.Left  _
                (.ChartArea.Width -.PlotArea.Width - .PlotArea.Left) / 2
            End If
        End If
    End With
End Function

下面是如何从一个过程调用该函数，这个过程确定选择了哪些图表，并将函数应用于每个图表。

代码语言：javascript复制

Sub SquareXYGridOfSelectedCharts()
    If Not ActiveChart Is Nothing Then
        squareXYChartGrid ActiveChart, True,True
    ElseIf TypeName(Selection) ="DrawingObjects" Then
        Dim shp As Shape
        For Each shp In Selection.ShapeRange
            If shp.HasChart Then
                squareXYChartGrid shp.Chart,True, True
            End If
        Next
    Else
        MsgBox "选择一个或多个图表,再试试.",vbExclamation, "没有选择图表"
    End If
End Sub

注：本文学习整理自peltiertech.com，一个专注于Excel图表的网站。

欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。

vba com excel 图表

0 人点赞