基于单元格值更改形状颜色的VBA代码优化请求

问题背景 #

Excel中C列包含数百个手动输入值，同时存在20个名称为Item-1至Item-20的形状按钮，按钮文本如Apple、Banana等，部分文本在C列中存在。现有VBA宏可根据文本是否在C列存在，将形状填充色设为黄色（vbYellow）或青色（vbCyan），但代码过于冗长，需要更精简的实现方式。

原始冗长代码 #

Sub Change_Shape_Color()
Dim rFound As Range
Dim rFound2 As Range
Dim rFound3 As Range
Dim rFound4 As Range
Dim rFound5 As Range
Dim rFound6 As Range
Dim rFound7 As Range
Dim rFound8 As Range
Dim rFound9 As Range
Dim rFound10 As Range
Dim rFound11 As Range
Dim rFound12 As Range
Dim rFound13 As Range
Dim rFound14 As Range
Dim rFound15 As Range
Dim rFound16 As Range
Dim rFound17 As Range
Dim rFound18 As Range
Dim rFound19 As Range
Dim rFound20 As Range

    Set rFound = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-1").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound2 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-2").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound3 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-3").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound4 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-4").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound5 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-5").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound6 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-6").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound7 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-7").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound8 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-8").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound9 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-9").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound10 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-10").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound11 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-11").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound12 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-12").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound13 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-13").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound14 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-14").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound15 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-15").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound16 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-16").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound17 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-17").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound18 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-18").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound19 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-19").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    Set rFound20 = ActiveSheet.Columns(3).Find(What:=ActiveSheet.Shapes("Item-20").TextFrame.Characters.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If Not rFound Is Nothing Then
        ActiveSheet.Shapes("Item-1").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-1").Fill.ForeColor.RGB = vbCyan
    End If

    If Not rFound2 Is Nothing Then
        ActiveSheet.Shapes("Item-2").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-2").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound3 Is Nothing Then
        ActiveSheet.Shapes("Item-3").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-3").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound4 Is Nothing Then
        ActiveSheet.Shapes("Item-4").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-4").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound5 Is Nothing Then
        ActiveSheet.Shapes("Item-5").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-5").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound6 Is Nothing Then
        ActiveSheet.Shapes("Item-6").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-6").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound7 Is Nothing Then
        ActiveSheet.Shapes("Item-7").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-7").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound8 Is Nothing Then
        ActiveSheet.Shapes("Item-8").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-8").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound9 Is Nothing Then
        ActiveSheet.Shapes("Item-9").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-9").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound10 Is Nothing Then
        ActiveSheet.Shapes("Item-10").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-10").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound11 Is Nothing Then
        ActiveSheet.Shapes("Item-11").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-11").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound12 Is Nothing Then
        ActiveSheet.Shapes("Item-12").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-12").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound13 Is Nothing Then
        ActiveSheet.Shapes("Item-13").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-13").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound14 Is Nothing Then
        ActiveSheet.Shapes("Item-14").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-14").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound15 Is Nothing Then
        ActiveSheet.Shapes("Item-15").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-15").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound16 Is Nothing Then
        ActiveSheet.Shapes("Item-16").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-16").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound17 Is Nothing Then
        ActiveSheet.Shapes("Item-17").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-17").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound18 Is Nothing Then
        ActiveSheet.Shapes("Item-18").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-18").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound19 Is Nothing Then
        ActiveSheet.Shapes("Item-19").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-19").Fill.ForeColor.RGB = vbCyan
    End If
    
    If Not rFound20 Is Nothing Then
        ActiveSheet.Shapes("Item-20").Fill.ForeColor.RGB = vbYellow
    Else
        ActiveSheet.Shapes("Item-20").Fill.ForeColor.RGB = vbCyan
    End If
    
End Sub

精简后的代码 #

Sub Change_Shape_Color()
    Dim i As Integer
    Dim targetShape As Shape
    Dim searchText As String
    Dim rFound As Range
    
    ' 遍历Item-1到Item-20
    For i = 1 To 20
        Set targetShape = ActiveSheet.Shapes("Item-" & i)
        searchText = targetShape.TextFrame.Characters.Text
        
        ' 在C列查找文本
        Set rFound = ActiveSheet.Columns(3).Find( _
            What:=searchText, _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            MatchCase:=False _
        )
        
        ' 根据查找结果设置填充色
        targetShape.Fill.ForeColor.RGB = IIf(Not rFound Is Nothing, vbYellow, vbCyan)
    Next i
End Sub

精简说明 #

• 使用For循环遍历所有20个形状，避免重复编写20次相同逻辑
• 仅使用单个Range变量复用，无需定义20个独立变量
• 用IIf函数简化条件判断，直接赋值颜色，减少冗余的If-Else块
• 代码结构更清晰，后续若需调整形状数量，只需修改循环的上下限即可

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