• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Fill the shape with color if the text inside it is similar to text in a clicked cell.

kenducot

New Member
I have multiple shapes linked to cell as text box. When I select say Cell A1 rectangle 20 which is linked to it will be filled with green color. However, I have more than 200 rectangles and I want this process to be automatic without individually typing a code for each shape linked to cell. Each text in every rectangle is linked to any cell with similar text in Column A. That means if one of the cell clicked in column A has the same text inside one of the shapes, then that corresponding shape will be filled with green color. Is it possible to create a general code based on this correspondence? Thank you.

The following is my crude vba code.

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'Fill previous shapes with white color and fill "rectangle 1" with green color
If Target.Row = 1 And Target.Column = 1 Then
ActiveSheet.Shapes.SelectAll
With Selection.ShapeRange.Fill
.ForeColor.RGB = vbWhite

ActiveCell.Select
ActiveSheet.Shapes("Rectangle 1").Fill.ForeColor.RGB = vbGreen

End With
End If

'Fill previous shapes with white color and fill "rectangle 2" with green color
If Target.Row = 2 And Target.Column = 1 Then
ActiveSheet.Shapes.SelectAll
With Selection.ShapeRange.Fill
.ForeColor.RGB = vbWhite

ActiveCell.Select
ActiveSheet.Shapes("Rectangle 2").Fill.ForeColor.RGB = vbGreen

End With
End If

End Sub
VBA3.JPG
 
Last edited by a moderator:

Hui

Excel Ninja
Staff member
Kenducot

Firstly, Welcome to the Chandoo.org Forums

Your example is unclear?

What is the link between Rectangle 20, and MMM and cell A3 and the color?

What do you want to happen and when ?

Please attach an actual Excel file, not a picture
 

Fluff13

Active Member
How about
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Shp As Shape
  
   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("A2:A200")) Is Nothing Then
      For Each Shp In Me.Shapes
         If Trim(Shp.DrawingObject.Formula) = Target.Address Then
            Shp.fill.ForeColor.RGB = vbGreen
         Else
            Shp.fill.ForeColor.RGB = vbWhite
         End If
      Next Shp
   End If
End Sub
 

kenducot

New Member
How about
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Shp As Shape
 
   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("A2:A200")) Is Nothing Then
      For Each Shp In Me.Shapes
         If Trim(Shp.DrawingObject.Formula) = Target.Address Then
            Shp.fill.ForeColor.RGB = vbGreen
         Else
            Shp.fill.ForeColor.RGB = vbWhite
         End If
      Next Shp
   End If
End Sub

Fluff13, thank you very much!!! it works perfectly! thank you very much for your generosity.
 

kenducot

New Member
Kenducot

Firstly, Welcome to the Chandoo.org Forums

Your example is unclear?

What is the link between Rectangle 20, and MMM and cell A3 and the color?

What do you want to happen and when ?

Please attach an actual Excel file, not a picture
Sorry for the unclear post. Thank you very much for taking time.
 

kenducot

New Member
When I group the shapes or some of the shapes, I get an error. Is there a way to bypass this error? Thanks

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Shp As Shape
 
   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("A2:A200")) Is Nothing Then
      For Each Shp In Me.Shapes
         If Trim(Shp.DrawingObject.Formula) = Target.Address Then
            Shp.fill.ForeColor.RGB = vbGreen
         Else
            Shp.fill.ForeColor.RGB = vbWhite
         End If
      Next Shp
   End If
End Sub
 
Last edited by a moderator:

kenducot

New Member
The code works if the shapes are not grouped.

kenducot
How many times should someone teach You how to use those code - tags?

Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Shp As Shape

   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("A2:A200")) Is Nothing Then
      For Each Shp In Me.Shapes
         If Trim(Shp.DrawingObject.Formula) = Target.Address Then
            Shp.fill.ForeColor.RGB = vbGreen
         Else
            Shp.fill.ForeColor.RGB = vbWhite
         End If
      Next Shp
   End If
End Sub
Here's the file.
 

Attachments

Last edited by a moderator:

Fluff13

Active Member
How about
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Shp As Shape, Shp1 As Shape
 
   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("A:A")) Is Nothing Then
      For Each Shp In Me.Shapes
         If Shp.Type = 6 Then
            For Each Shp1 In Shp.GroupItems
               If Trim(Shp1.DrawingObject.Formula) = Target.Address Then
                  Shp1.Fill.ForeColor.RGB = vbGreen
               Else
                  Shp1.Fill.ForeColor.RGB = vbWhite
               End If
            Next Shp1
         Else
            If Trim(Shp.DrawingObject.Formula) = Target.Address Then
               Shp.Fill.ForeColor.RGB = vbGreen
            Else
               Shp.Fill.ForeColor.RGB = vbWhite
            End If
         End If
      Next Shp
   End If
End Sub
But you need to make sure that the main rectangle (Rectangle 21) is behind the other shapes
 

kenducot

New Member
Gowrisankar A, thank you very much. Your code works but I forgot to mention that the no of grouped shapes is variable. Thank you.
Fluff13, thank you very much. your code works even if I add more shapes!!


Thank you very much to all who have helped me!
 
Last edited:
Top