问Excel散点图背景色可以根据数据值定制吗？

EN

Sub scatter_plot_simple()
    Const CHT_NAME As String = "QUADRANTS"
    Dim cht As Chart, rngX As Range, rngY As Range, wsData As Worksheet, co
    Dim medX, medY, wsChart As Worksheet
    
    Set wsChart = Worksheets("Chart")
    Set wsData = Worksheets("Data")
    Set rngX = wsData.Range("B2:B400")
    Set rngY = wsData.Range("C2:C400")
    
    DeleteAllShapes wsChart
    
    'hosting the chart on a worksheet...
    Set co = wsChart.Shapes.AddChart2(240, xlXYScatter)
    co.Name = CHT_NAME
    co.Fill.Visible = msoFalse 'no background
    co.Top = 10
    co.Left = 10
    co.Width = 400
    co.Height = 400
    
    Set cht = co.Chart
    ClearSeries cht    'make sure no "auto-plotted" series
    With cht
        .ChartType = xlXYScatter
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = "Data"
        .SeriesCollection(1).XValues = rngX
        .SeriesCollection(1).Values = rngY
        .PlotArea.Format.Fill.Visible = msoFalse 'no background
    End With
    
    medX = Application.Median(rngX)
    medY = Application.Median(rngY)
    
    AddQuadrants cht, medX, medY
    
End Sub

Sub AddQuadrants(cht As Chart, medX, medY)
 
    Dim minX, maxX, minY, maxY, xAxis As Axis, yAxis As Axis
    Dim xSpan, ySpan, shp1, Q1 As Shape, Q2 As Shape, Q3 As Shape, Q4 As Shape
    Dim Q1W, Q1H, ws As Worksheet, co As Object, posTop As Long, posleft As Long
    
    Set co = cht.Parent 'chartobject (a container for the chart when hosted on a worksheet)
    Set ws = co.Parent  'the hosting worksheet
    
    Set xAxis = cht.Axes(xlCategory)
    Set yAxis = cht.Axes(xlValue)
    
    minX = xAxis.MinimumScale
    maxX = xAxis.MaximumScale
    xSpan = maxX - minX
    
    minY = yAxis.MinimumScale
    maxY = yAxis.MaximumScale
    ySpan = maxY - minY
    
    Q1W = ((medX - minX) / xSpan) * xAxis.Width
    Q1H = ((maxY - medY) / ySpan) * yAxis.Height
    
    posTop = 4 + co.Top + yAxis.Top     'fudging this a bit...
    posleft = 4 + co.Left + xAxis.Left  'fudging this a bit...
    
    Set Q1 = Quadrant(ws, posleft, posTop, Q1W, Q1H, vbYellow)
    Set Q2 = Quadrant(ws, posleft + Q1W, posTop, xAxis.Width - Q1W, Q1H, vbRed)
    Set Q3 = Quadrant(ws, posleft, posTop + Q1H, Q1W, yAxis.Height - Q1H, vbBlue)
    Set Q4 = Quadrant(ws, posleft + Q1W, posTop + Q1H, _
                      xAxis.Width - Q1W, yAxis.Height - Q1H, vbGreen)
    
End Sub

Function Quadrant(ws As Worksheet, l, t, w, h, clr As Long) As Shape
    Dim rv As Shape
    Set rv = ws.Shapes.AddShape(msoShapeRectangle, l, t, w, h)
    rv.Fill.ForeColor.RGB = clr
    rv.Fill.Transparency = 0.9
    rv.Fill.Solid
    rv.Line.Visible = False
    rv.ZOrder msoSendToBack
    Set Quadrant = rv
End Function

Sub ClearSeries(cht As Chart)
    Do While cht.SeriesCollection.Count > 0
        cht.SeriesCollection(1).Delete
    Loop
End Sub

Sub DeleteAllShapes(ws As Worksheet)
    Do While ws.Shapes.Count > 0
       ws.Shapes(1).Delete
    Loop
End Sub

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