时间戳

首页 > 解决方案 > Excel散点图背景颜色可以根据数据值自定义吗？

excel - Excel散点图背景颜色可以根据数据值自定义吗？

问题描述

我有一个 5row x 2col 表 - 有 5 个数据点，每个数据点都有相应的 X 和 Y 值。X,Y 值用于绘制散点图。

我想编写一个 VBA 代码来自定义散点图的背景作为数据点本身的函数，即彩色矩形的 X 和 Y 范围应该在我的控制范围内。理想情况下，我希望数据中的 X 和 Y 中值分别使 X 和 Y “轴”成为不同颜色矩形的边界。我该怎么做？

在此处输入图像描述

目前我只是在格式化图表区域时选择了“形状填充”->“图片”选项。图片目前是在 MS Powerpoint 中手动创建的，与图表区域的纵横比相同。

编辑：我包括一个最小可重现的示例 VBA 代码。它从“Sheet1”中 A2:B6 范围内的 5x2 表中获取数据。希望这可以帮助！

Sub scatter_plot_simple()
Dim Chart1 As Chart
Set Chart1 = Charts.Add
With Chart1
    .ChartType = xlXYScatter
    .SeriesCollection.NewSeries
    .SeriesCollection(1).Name = "=""Values"""
    .SeriesCollection(1).XValues = "=Sheet1!$B$2:$B$6"
    .SeriesCollection(1).Values = "=Sheet1!C$2:$C$6"
End With

结束子

标签： excelvbaplot

解决方案

请尝试下一段代码。它将创建矩形，为它们着色，分组，导出组图片并将其添加为绘图仪区域用户图片。没时间评论代码。如果不清楚，我会在几个小时内发表评论，当我在家时：

Sub scatter_plot_simple()
    Dim sC As Chart, sh As Worksheet, Chart1 As Chart, sGr As Shape, s As Shape, s1 As Shape, s2 As Shape
    Dim pltH As Double, pltW As Double, pltAH As Double, pltAW As Double, i As Long, j As Long, k As Long
    Dim maxX As Long, maxY As Long, majUnitY As Long, topS As Double, leftS As Double
    
    majUnitY = 20 'major unity for X axes
    'delete the previous chart (used for testing)
    For Each sC In Charts
        Application.DisplayAlerts = False
            If sC.Name = "MyChart" Then sC.Delete: Exit For
        Application.DisplayAlerts = True
    Next
    Set sh = Sheets("Sheet1")
    Set Chart1 = Charts.Add
    With Chart1
        .Name = "MyChart"
        .ChartType = xlXYScatter
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = "=""Values"""
        .SeriesCollection(1).XValues = "=" & sh.Name & "!B2:B6"
        .SeriesCollection(1).Values = "=" & sh.Name & "!C2:C6"
        .Axes(xlCategory).MajorUnit = majUnitY
        maxX = .Axes(xlCategory).MaximumScale             'maximum scale of X axes
        pltAH = .PlotArea.height: pltAW = .PlotArea.width 'plot area height
        maxY = .Axes(xlValue).MaximumScale                'maximum scale of X axes
        'extract dimensions of the future rectangles to be created:
        pltH = .PlotArea.height / maxY: pltW = .PlotArea.width / (maxX / majUnitY)
    End With
    'create the rectangle equal to chart Plot area:
    Set s = sh.Shapes.AddShape(msoShapeRectangle, 0, 0, pltAW, pltAH)
    s.Fill.ForeColor.RGB = RGB(255, 255, 255) 'white color
    topS = 0: leftS = 0
    Dim maxGreen As Long  ' variable to be used to change the rectangle colors
    maxGreen = 2
    'create the necessary colored rectangles to reflect the maximum X and maximum Y
    For j = 1 To maxX / majUnitY
        For i = 1 To 6
            Set s1 = sh.Shapes.AddShape(msoShapeRectangle, leftS, topS, pltW, pltH)
            With s1
                .Select
                'color rectangles according to their position:
                .Fill.ForeColor.RGB = IIf(6 - i >= maxGreen, IIf(j = 1, RGB(201, 163, 102), RGB(138, 197, 139)), IIf(j = 1, RGB(231, 157, 126), RGB(145, 208, 215)))
                .line.Weight = 2
                .line.ForeColor.RGB = RGB(255, 255, 255)
            End With
            If i = 1 And j = 1 Then  'group the big rectangle (plot area dimensions) with the first rectangle
                Set sGr = sh.Shapes.Range(Array(s.Name, s1.Name)).Group
            Else
                'group the previous group with the created rectangle
                Set sGr = sh.Shapes.Range(Array(sGr.Name, s1.Name)).Group
            End If
            topS = topS + pltH  'increment Top position for the future rectangle
        Next i
        'adding the rectangles slices over the existing rectangles in second column:
        If j = 2 Then
            topS = 0
            For k = 1 To 6
                Set s2 = sh.Shapes.AddShape(msoShapeRectangle, leftS + 2, topS + 2, pltW / 3, pltH - 4)
                With s2
                    .Select
                    If 6 - k >= maxGreen Then
                        .Fill.ForeColor.RGB = RGB(201, 163, 102)
                        .line.ForeColor.RGB = RGB(201, 163, 102)
                    Else
                        .Fill.ForeColor.RGB = RGB(231, 157, 126)
                        .line.ForeColor.RGB = RGB(231, 157, 126)
                    End If
                End With
                Set sGr = sh.Shapes.Range(Array(sGr.Name, s2.Name)).Group
                topS = topS + pltH
            Next k
            
        End If
        leftS = leftS + pltW: topS = 0 'increment the left possition and reset the Top poz to zero
    Next j
    'Part of exporting the created group as picture:
    Dim pictPath As String
    pictPath = ThisWorkbook.path & "\chartPict.jpg" 'the path where to be saved
    ExportShPict sGr, sh, pictPath                          'export function
    Chart1.PlotArea.Format.Fill.UserPicture pictPath   'place the exported picture to the chart plot area
    sGr.Delete                                                   'delete the helper group
    Chart1.Activate                                            'activate the chart sheet
    MsgBox "Ready..."
End Sub

Private Sub ExportShPict(s As Shape, sh As Worksheet, pictPath As String)
   Dim ch As ChartObject
   'create a new chart using the shape (group) dimensions
   Set ch = sh.ChartObjects.Add(left:=1, top:=1, width:=100, height:=100)
   ch.width = s.width: ch.height = s.height
   'copy the group picture on the newly created chart
   s.CopyPicture: ch.Activate: ActiveChart.Paste
   'export the chart which practically means only the picture
   ch.Chart.Export FileName:=pictPath, FilterName:="JPG"
   ch.Delete 'delete the helper chart
End Sub

我推导出了更改垂直轴颜色的逻辑，但是您没有说明 X 轴上要更改向下颜色的位置。如果这方面清楚，可以在第二个矩形列上放置一些较小的矩形。

推荐阅读