excelvba

change color of shapes based on cell values vba

I have column C with hundreds of cell values. also, I type values manually in that column.

I also have some buttons created with shapes. (20 shapes). Shape name is Like Item-1, Item-2, Item-3 to Item-20)

And shape values are like, Apple, Banana, Orange etc.

Apple, Banana, Orange are also available somewhere in column c. means Some shape value also available in column C.

If I run below macro, it changes color of shapes if shape values found in column c.

and If shape values are not match then it should be a deferent color.

Required thing is, if an item is available in list than highlight that represent button (Shape).

Below code is working fine. and it is a long way.

Image-1 for illustration Image-2 for illustration Image-3 for illustration

If any shorten code is available, then please help me.

This is my fully working code. But it is very very long.

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

Many thanks in advance.

Solution

  • Adjust Shape Colors Using List of Texts

    enter image description here

    Sub AdjustShapeColors()
    
    Const TOP_CELL_ADDRESS As String = "C2"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim rg As Range, lcell As Range
    
    With ws.Range(TOP_CELL_ADDRESS)
        With .Resize(ws.Rows.Count - .Row + 1) ' i.e. C2:C1048576
            Set lcell = .Find("*", , xlFormulas, , , xlPrevious)
            If lcell Is Nothing Then
                MsgBox "No data found in """ & .Address(0, 0) _
                    & """ of sheet """ & ws.Name & """!", vbExclamation
                Exit Sub
            End If
        End With
        Set rg = .Resize(lcell.Row - .Row + 1)
    End With
    
    Dim shp As Shape, ShapeColor As Long, ShapeText As String
    Dim WasShapeFound As Boolean
    
    For Each shp In ws.Shapes
        WasShapeFound = True
        ShapeText = shp.TextFrame.Characters.Text
        If IsNumeric(Application.Match(ShapeText, rg, 0)) Then
            ShapeColor = vbYellow
        Else
            ShapeColor = vbRed
        End If
        shp.Fill.ForeColor.RGB = ShapeColor
    Next shp

    If WasShapeFound Then
        MsgBox "Shape colors adjusted.", vbInformation
    Else
        MsgBox "No shapes found on sheet """ & ws.Name & """!", vbExclamation
    End If
    
End Sub

    EDIT

    Sub AdjustShapeColors()
    
    ' Define constants.
    Const TOP_CELL_ADDRESS As String = "C2"
    Const SHAPES_COUNT As Long = 20
    Const SHAPE_BASE_NAME As String = "Item-"
    Const COLOR_YES As Long = vbYellow
    Const COLOR_NO As Long = vbCyan
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the single-column range.
    Dim rg As Range, lcell As Range
    With ws.Range(TOP_CELL_ADDRESS)
        With .Resize(ws.Rows.Count - .Row + 1) ' i.e. C2:C1048576
            Set lcell = .Find("*", , xlFormulas, , , xlPrevious)
            If lcell Is Nothing Then
                MsgBox "No data found in """ & .Address(0, 0) _
                    & """ of sheet """ & ws.Name & """!", vbExclamation
                Exit Sub
            End If
        End With
        Set rg = .Resize(lcell.Row - .Row + 1)
    End With
    
    ' Build the shape names and return them in an array.
    Dim ShapeNames() As String: ReDim ShapeNames(1 To SHAPES_COUNT)
    Dim i As Long
    For i = 1 To SHAPES_COUNT
        ShapeNames(i) = SHAPE_BASE_NAME & i
    Next i
    
    ' Loop through the array and adjust the shape colors
    ' depending on whether their names are found in the column.
    Dim shp As Shape, ShapeName As Variant, ShapeColor As Long
    Dim WasShapeFound As Boolean
    For Each ShapeName In ShapeNames
        Set shp = Nothing
        On Error Resume Next ' prevent error if shape not found
            Set shp = ws.Shapes(ShapeName)
        On Error GoTo 0
        If Not shp Is Nothing Then ' shape found
            WasShapeFound = True
            If IsNumeric(Application.Match(ShapeName, rg, 0)) Then ' found...
                ShapeColor = COLOR_YES
            Else ' not found in column
                ShapeColor = COLOR_NO
            End If
            shp.Fill.ForeColor.RGB = ShapeColor
        End If
    Next ShapeName
    
    ' Inform.
    If WasShapeFound Then
        MsgBox "Shape colors adjusted.", vbInformation
    Else
        MsgBox "No shapes found on sheet """ & ws.Name & """!", vbExclamation
    End If
    
End Sub