根据值更改散点图中特定点的形状

Posted 2021-03-27

我需要一个散点图来根据不同的值调整标记的颜色和形状。我发现下面的代码非常适合更改颜色，是否可以调整此代码或更新代码以根据不同的列值更改标记以包含圆形，三角形，正方形等？

谢谢！

Sub ColorScatterPoints3()
    Dim cht As Chart
    Dim srs As Series
    Dim pt As Point
    Dim p As Long
    Dim Vals$, lTrim#, rTrim#
    Dim valRange As Range, cl As Range
    Dim myColor As Long

    Set cht = ActiveSheet.ChartObjects(1).Chart
    Set srs = cht.SeriesCollection(1)

   '## Get the series Y-Values range address:
    lTrim = InStrRev(srs.Formula, ",", InStrRev(srs.Formula, ",") - 1, vbBinaryCompare) + 1
    rTrim = InStrRev(srs.Formula, ",")
    Vals = Mid(srs.Formula, lTrim, rTrim - lTrim)
    Set valRange = Range(Vals)

    For p = 1 To srs.Points.Count
        Set pt = srs.Points(p)
        Set cl = valRange(p).Offset(0, 1) '## assume color is in the next column.

        With pt.Format.Fill
            .Visible = msoTrue
            '.Solid  'I commented this out, but you can un-comment and it should still work
            '## Assign Long color value based on the cell value
            '## Add additional cases as needed.
            Select Case LCase(cl)
                Case "red"
                    myColor = RGB(255, 0, 0)
                Case "blue"
                    myColor = RGB(0, 0, 255)
                Case "green"
                    myColor = RGB(0, 255, 0)
                    Case "yellow"
                    myColor = RGB(255, 192, 50)

            End Select

            .ForeColor.RGB = myColor

        End With
    Next
End Sub

答案

这样的事情应该有效。我实际上在研究答案时学到了一些东西。我不知道如何使用Select Case。谢谢你提问！

如果您想添加更多形状选项，请参阅此文章：https://docs.microsoft.com/en-us/office/vba/api/excel.series.markerstyle

我的示例数据和结果：

Sub ColorScatterPoints3()
    Dim cht As Chart
    Dim srs As Series
    Dim pt As Point
    Dim p As Long
    Dim Vals$, lTrim#, rTrim#
    Dim valRange As Range, cl As Range
    Dim myColor As Long
    Dim myShape As String

    Set cht = ActiveSheet.ChartObjects(1).Chart
    Set srs = cht.SeriesCollection(1)

   '## Get the series Y-Values range address:
    lTrim = InStrRev(srs.Formula, ",", InStrRev(srs.Formula, ",") - 1, vbBinaryCompare) + 1
    rTrim = InStrRev(srs.Formula, ",")
    Vals = Mid(srs.Formula, lTrim, rTrim - lTrim)
    Set valRange = Range(Vals)

    For p = 1 To srs.Points.Count
        Set pt = srs.Points(p)
        Set cl = valRange(p).Offset(0, 1) '## assume color is in the next column.
        Set shp = valRange(p).Offset(0, 2) '## assume shape is in column next to color.

        'Color Change
        With pt.Format.Fill
            .Visible = msoTrue
            '.Solid  'I commented this out, but you can un-comment and it should still work
            '## Assign Long color value based on the cell value
            '## Add additional cases as needed.
            Select Case LCase(cl)
                Case "red"
                    myColor = RGB(255, 0, 0)
                Case "blue"
                    myColor = RGB(0, 0, 255)
                Case "green"
                    myColor = RGB(0, 255, 0)
                    Case "yellow"
                    myColor = RGB(255, 192, 50)

            End Select

            .ForeColor.RGB = myColor

        End With

        'Shape Change
        With pt
            '## Assign shape value based on the cell value
            '## Add additional cases as needed.
            Select Case LCase(shp)
                Case "square"
                    myShape = xlMarkerStyleSquare
                Case "triangle"
                    myShape = xlMarkerStyleTriangle
                Case "circle"
                    myShape = xlMarkerStyleCircle
                Case "x"
                    myShape = xlMarkerStyleX
                Case "+"
                    myShape = xlMarkerStylePlus

            End Select

            .MarkerStyle = myShape

        End With

    Next
End Sub