• 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:
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
 
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
 
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

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.
 
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:
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

  • Change shape color through selections.xlsm
    18.5 KB · Views: 4
Last edited by a moderator:
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
 
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:
Back
Top