如何基于表格单元格值循环控制形状？VBA代码优化求助

你的代码存在大量重复的判断逻辑，完全可以通过循环+配置数组的方式简化，同时还能修正原代码里的几个小问题：

• 逻辑判断中误用了&（字符串连接符），VBA里逻辑与应该用And
• 处理G7单元格时，误写了Range("F6")，正确应为Range("F7")
• 部分Range和Shapes未指定工作表，容易出现引用错误

优化后的代码 #

Sub L0worksheet_change()
    Dim WBPT As Workbook
    Dim L0 As Worksheet
    Dim rowConfig As Variant
    Dim i As Integer
    Dim targetVal As Double, lowerVal As Double, upperVal As Double
    
    ' 初始化工作簿和工作表对象
    Set WBPT = Workbooks("Progress_Tables.xlsm")
    Set L0 = WBPT.Worksheets("L0_ProgressT")
    
    ' 配置数组：每一行对应【行号, 红色形状名, 黄色形状名, 绿色形状名】
    rowConfig = Array( _
        Array(4, "Arrow: Down 1", "Arrow: Right 2", "Arrow: Up 3"), _
        Array(5, "MiRed", "MiAmber", "MiGreen"), _
        Array(6, "RaRed", "RaAmber", "RaGreen"), _
        Array(7, "MESRed", "MESAmber", "MESGreen") _
    )
    
    ' 遍历每一行配置
    For i = LBound(rowConfig) To UBound(rowConfig)
        With L0
            ' 获取当前行的关键值
            targetVal = .Cells(rowConfig(i)(0), "G").Value
            lowerVal = .Cells(rowConfig(i)(0), "L").Value
            upperVal = .Cells(rowConfig(i)(0), "F").Value
            
            ' 先默认隐藏所有形状
            .Shapes(rowConfig(i)(1)).Visible = msoFalse
            .Shapes(rowConfig(i)(2)).Visible = msoFalse
            .Shapes(rowConfig(i)(3)).Visible = msoFalse
            
            ' 根据值的范围显示对应形状
            If targetVal < lowerVal Then
                .Shapes(rowConfig(i)(1)).Visible = msoTrue
            ElseIf targetVal > upperVal Then
                .Shapes(rowConfig(i)(3)).Visible = msoTrue
            ElseIf targetVal > lowerVal And targetVal < upperVal Then
                .Shapes(rowConfig(i)(2)).Visible = msoTrue
            End If
        End With
    Next i
    
    ' 释放对象
    Set L0 = Nothing
    Set WBPT = Nothing
End Sub

优化点说明 #

• 配置数组：把每行的行号和对应形状名集中管理，后续新增行或修改形状名，直接修改数组即可，无需重复编写判断逻辑
• 统一工作表引用：用With L0确保所有Range和Shapes都指向目标工作表，避免隐式引用错误
• 简化判断逻辑：先默认隐藏所有形状，再根据条件显示对应形状，减少重复赋值语句
• 变量提取：提前将单元格值存入变量，避免多次读取单元格，提升运行效率

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