VBA coding for conditionally formatting a shape

[Benton]

Good Day ,

i've been searching for a way to be able to auto fill in a shape with a certain color according to a cell value. I have 5 different cell value options and I was looking for a way to change a shape color based on an in-cell drop down list.

i have attached the sample file i'm working on. the idea is after assessing a certian area, the user to select (from the in-cell drop down list) the estimated area deteriorated. then the corresponding area shape to auto fill with the correct color. it should be more clear if you see the attached.

would appreciate any help/advise.

regards,
Ben

 

[Debraj]

Hi Benton,

Welcome to the forum..

Please check the attached file..
Few things has been change.. like DropDown & few Conditional Formatting..

Pleas giev a look.. at the attached..

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [q6:Q14]) Is Nothing Then
    debcolor = Range("U15").Offset(Application.Match(Target, Range("U16:U20"), False), 2).Interior.Color
    RGBColour = Right("000000" & Hex(debcolor), 6)
    r = Evaluate("Hex2Dec(" & Chr(34) & Right(RGBColour, 2) & Chr(34) & ")")
    g = Evaluate("Hex2Dec(" & Chr(34) & Mid(RGBColour, 3, 2) & Chr(34) & ")")
    b = Evaluate("Hex2Dec(" & Chr(34) & Left(RGBColour, 2) & Chr(34) & ")")
        Shapes("Shape " & Target.Offset(, -9)).Fill.BackColor.RGB = RGB(r, g, b)
    End If
End Sub

 

[Benton]

Hi Benton,

Welcome to the forum..

Please check the attached file..
Few things has been change.. like DropDown & few Conditional Formatting..

Pleas giev a look.. at the attached..

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [q6:Q14]) Is Nothing Then
    debcolor = Range("U15").Offset(Application.Match(Target, Range("U16:U20"), False), 2).Interior.Color
    RGBColour = Right("000000" & Hex(debcolor), 6)
    r = Evaluate("Hex2Dec(" & Chr(34) & Right(RGBColour, 2) & Chr(34) & ")")
    g = Evaluate("Hex2Dec(" & Chr(34) & Mid(RGBColour, 3, 2) & Chr(34) & ")")
    b = Evaluate("Hex2Dec(" & Chr(34) & Left(RGBColour, 2) & Chr(34) & ")")
        Shapes("Shape " & Target.Offset(, -9)).Fill.BackColor.RGB = RGB(r, g, b)
    End If
End Sub

I can not thank you enough for the quick response and the AMAZING job!!

Thanks again Debraj................you really are an excel ninja!

Regards,
Ben

 

[Benton]

Hello again Debraj,

I need your help yet again on the same issue. I have taken your coding and applied to to my original workbook and it worked fine after adjusting the cell references.

I am facing another problem when applying the same coding to two other worksheet with similar diagrams.

it get the following error from VBA:-

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [q9:Q17]) Is Nothing Then
debcolor = Range("U18").Offset(Application.Match(Target, Range("U19:U23"), False), 2).Interior.Color
RGBColour = Right("000000" & Hex(debcolor), 6)
r = Evaluate("Hex2Dec(" & Chr(34) & Right(RGBColour, 2) & Chr(34) & ")")
g = Evaluate("Hex2Dec(" & Chr(34) & Mid(RGBColour, 3, 2) & Chr(34) & ")")
b = Evaluate("Hex2Dec(" & Chr(34) & Left(RGBColour, 2) & Chr(34) & ")")
Shapes("Shape " & Target.Offset(, -9)).Fill.BackColor.RGB = RGB(r, g, b)
End If
End Sub

the blue colored font above is highlighted in the vba debug window.

I have attached the remaining two worksheets and would be greatful if you could take a look at them and assist me.

Thanks in advance,
Ben

 

[Debraj]

 

[Benton]

View attachment 2578

Many thanks Debraj!!!