Excel 2016: Worksheet Change Event, repeat for many cells

[ajay_gajree]

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) Then
        If Target.Value < 2 Then
            ActiveSheet.Shapes("srRectangle1").Fill.ForeColor.RGB = RGB(255, 0, 0)
        ElseIf Target.Value >= 2 And Target.Value < 3 Then
            ActiveSheet.Shapes("srRectangle1").Fill.ForeColor.RGB = RGB(255, 192, 0)
        Else
            ActiveSheet.Shapes("srRectangle1").Fill.ForeColor.RGB = RGB(0, 255, 0)
        End If
    End If
End Sub

Hi All

I have the above code which changes the colour of a shape, srRectangle1 based on a cell value, A1

If I want to do the same for shape srRectangle2 based on cell value A2, is there a more efficient way than repeating the entire code and changing those values?
Ultimately I have 50 odd shapes in the same worksheet al looking at different cell values, so looking to avoid 50 change events!

Any help appreciated!

 

[Norie]

Try this.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("A1:A50")) Is Nothing Then Exit Sub

    If IsNumeric(Target.Value) Then
        If Target.Value < 2 Then
            ActiveSheet.Shapes("srRectangle" & Target.Row).Fill.ForeColor.RGB = RGB(255, 0, 0)
        ElseIf Target.Value >= 2 And Target.Value < 3 Then
            ActiveSheet.Shapes("srRectangle" & Target.Row).Fill.ForeColor.RGB = RGB(255, 192, 0)
        Else
            ActiveSheet.Shapes("srRectangle" & Target.Row).Fill.ForeColor.RGB = RGB(0, 255, 0)
        End If
    End If

End Sub

 

[ajay_gajree]

Thx a lot Norrie, that works.

A related question, Cells A1:A50 are formula based on Cell B1, so when I change the dropdown in B1 this changes the values in A1:A50 but this doesn't trigger the change in the shapes

Any idea why not?

Thx again!

 

[ajay_gajree]

Private Sub Worksheet_Calculate()
Dim target As Range
Dim i As Integer
Set target = Range("B3:B8")
    'If Intersect(target, Range("B3:B8")) Is Nothing Then Exit Sub
For i = 3 To 8
    If Range("B" & i) = "R" Then
            ActiveSheet.Shapes("srRectangle" & i - 1).Fill.ForeColor.RGB = RGB(255, 0, 0)
        ElseIf Range("B" & i) = "A" Then
            ActiveSheet.Shapes("srRectangle" & i - 1).Fill.ForeColor.RGB = RGB(255, 192, 0)
        ElseIf Range("B" & i) = "G" Then
            ActiveSheet.Shapes("srRectangle" & i - 1).Fill.ForeColor.RGB = RGB(0, 255, 0)
        Else
            ActiveSheet.Shapes("srRectangle" & i - 1).Fill.ForeColor.RGB = RGB(255, 255, 255)
        End If
Next i
End Sub

This was what I needed :)

Thx Norrie!

 

[Norie]

The change event won't be triggered when a value is changed as a result of a formula.

What you could do is monitor B1 instead of A1:A50, and when that changes loop through A1:A50.

Something like this.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range

    If Intersect(Target, Range("B1")) Is Nothing Then Exit Sub

    For Each cl In Range("A1:A50")

        If IsNumeric(cl.Value) Then
            If cl.Value < 2 Then
                ActiveSheet.Shapes("srRectangle" & cl.Row).Fill.ForeColor.RGB = RGB(255, 0, 0)
            ElseIf cl.Value >= 2 And cl.Value < 3 Then
                ActiveSheet.Shapes("srRectangle" & cl.Row).Fill.ForeColor.RGB = RGB(255, 192, 0)
            Else
                ActiveSheet.Shapes("srRectangle" & cl.Row).Fill.ForeColor.RGB = RGB(0, 255, 0)
            End If
        End If

    Next cl

End Sub