VBA散点图：用单元格范围替代Select Case硬编码实现动态格式设置

原代码通过Select Case硬编码设置散点图标记的形状与颜色，新增选项必须修改代码，维护成本高。以下是优化后的实现，通过读取Formatting工作表的配置表，让用户直接在表格中新增/修改配置，无需编辑VBA代码。

第一步：建立配置表 #

在Formatting工作表中创建如下结构的配置表（可按需扩展行数）：

标记形状对应VBA常量：Diamond=xlMarkerStyleDiamond，Circle=xlMarkerStyleCircle，Square=xlMarkerStyleSquare，Triangle=xlMarkerStyleTriangle等，可根据需求填写对应名称

第二步：优化后的VBA代码 #

Sub CreateColorScatterPointsCT()
    On Error GoTo Er
    Dim Cht As Chart
    Dim srs As Series
    Dim pt As Point
    Dim p As Long
    Dim Vals$, lTrim#, rTrim#
    Dim valRange As Range, optCell As Range
    Dim configWs As Worksheet
    Dim configDict As Object
    Dim configArr As Variant
    Dim i As Long
    Dim optName As String
    Dim myShape As XlMarkerStyle
    Dim myColor As Long
    Dim markerSize As Integer
    Dim lineWeight As Double

    '初始化配置字典
    Set configDict = CreateObject("Scripting.Dictionary")
    Set configWs = ThisWorkbook.Worksheets("Formatting")
    
    '读取配置表数据（假设表头在第1行，数据从第2行开始）
    configArr = configWs.Range("A2:G" & configWs.Cells(configWs.Rows.Count, "A").End(xlUp).Row).Value
    For i = LBound(configArr) To UBound(configArr)
        optName = LCase(configArr(i, 1))
        '将配置存入字典：键为选项名称（小写），值为参数数组
        configDict(optName) = Array( _
            GetMarkerStyle(configArr(i, 2)), _
            RGB(configArr(i, 3), configArr(i, 4), configArr(i, 5)), _
            configArr(i, 6), _
            configArr(i, 7) _
        )
    Next i

    '获取图表和数据系列
    Set Cht = ActiveSheet.ChartObjects(1).Chart
    Set srs = Cht.SeriesCollection(1)

    '提取数据范围
    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 optCell = valRange(p).Offset(0, 1) '假设选项名称在Y值右侧第1列
        optName = LCase(optCell.Value)

        '设置默认参数
        myShape = xlMarkerStyleDiamond
        myColor = RGB(0, 0, 0)
        markerSize = 8
        lineWeight = 0.75

        '从字典读取配置（如果存在）
        If configDict.Exists(optName) Then
            myShape = configDict(optName)(0)
            myColor = configDict(optName)(1)
            markerSize = configDict(optName)(2)
            lineWeight = configDict(optName)(3)
        End If

        '应用标记格式
        With pt
            .MarkerStyle = myShape
            .MarkerSize = markerSize
            .MarkerForegroundColor = RGB(0, 0, 0) '边框颜色固定为黑色，可按需加入配置
            .MarkerBackgroundColor = RGB(0, 0, 0)
            .Format.Line.Weight = lineWeight
            .Border.LineStyle = xlNone
            '应用填充颜色
            .Format.Fill.Visible = msoTrue
            .Format.Fill.ForeColor.RGB = myColor
        End With
    Next p

    Call AddDataLabels
Done:
    Exit Sub
Er:
    MsgBox "数据未定义或标记/标签数据错误" & vbNewLine & vbNewLine & "请确认选项数据已正确填充"
End Sub

'辅助函数：将形状名称转换为VBA常量
Function GetMarkerStyle(styleName As String) As XlMarkerStyle
    Select Case LCase(styleName)
        Case "diamond": GetMarkerStyle = xlMarkerStyleDiamond
        Case "circle": GetMarkerStyle = xlMarkerStyleCircle
        Case "square": GetMarkerStyle = xlMarkerStyleSquare
        Case "triangle": GetMarkerStyle = xlMarkerStyleTriangle
        Case "x": GetMarkerStyle = xlMarkerStyleX
        Case "star": GetMarkerStyle = xlMarkerStyleStar
        Case "plus": GetMarkerStyle = xlMarkerStylePlus
        Case Else: GetMarkerStyle = xlMarkerStyleDiamond '默认形状
    End Select
End Function

关键说明 #

• 配置字典：使用Scripting.Dictionary存储配置，通过选项名称快速查找对应参数，比Select Case效率更高，且支持动态扩展。
• 辅助函数：GetMarkerStyle将配置表中的形状名称转换为VBA对应的XlMarkerStyle常量，用户只需填写易读的名称即可。
• 默认参数：当配置表中找不到对应选项时，会自动应用默认的标记样式，避免报错。
• 数据列修正：原代码中形状和颜色指向同一列，优化后假设选项名称在Y值右侧第1列，所有配置通过选项名称关联，更简洁。

内容的提问来源于stack exchange，提问作者MikeF