Shape Colour based on Value or Cell Fill color

[naveeddil]

Dear All,

I have an excel sheet having some 30+ shapes which is making a map. I have given names to all the shapes as you can see in the below picture.

What i like is that i would like to color the different shapes based on their value in a table.


Excel File: http://s000.tinyupload.com/download.php?file_id=57118960552482861011&t=5711896055248286101138391


Please Help

 

[Akuini]

Hi, naveeddil
Try this:

[FONT=lucida console][COLOR=Royalblue]Sub[/COLOR] toColor()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1089154-shape-colour-based-value-cell-fill-color.html[/COLOR][/I]
[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR], x [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Double[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] va
[COLOR=Royalblue]Dim[/COLOR] d [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR]

va = Range([COLOR=brown]"B3:C"[/COLOR] & Cells(Rows.count, [COLOR=brown]"B"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp).Row)

[COLOR=Royalblue]For[/COLOR] i = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR])
    x = va(i, [COLOR=crimson]2[/COLOR])
    [COLOR=Royalblue]If[/COLOR] x < [COLOR=crimson]0.9[/COLOR] [COLOR=Royalblue]Then[/COLOR]
        va(i, [COLOR=crimson]2[/COLOR]) = [COLOR=crimson]255[/COLOR] [I][COLOR=seagreen]'red[/COLOR][/I]
        [COLOR=Royalblue]ElseIf[/COLOR] x >= [COLOR=crimson]0.9[/COLOR] [COLOR=Royalblue]And[/COLOR] x <= [COLOR=crimson]0.95[/COLOR] [COLOR=Royalblue]Then[/COLOR]
        va(i, [COLOR=crimson]2[/COLOR]) = [COLOR=crimson]49407[/COLOR] [I][COLOR=seagreen]'orange[/COLOR][/I]
        [COLOR=Royalblue]ElseIf[/COLOR] x > [COLOR=crimson]0.95[/COLOR] [COLOR=Royalblue]And[/COLOR] x <= [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]Then[/COLOR]
        va(i, [COLOR=crimson]2[/COLOR]) = [COLOR=crimson]5287936[/COLOR] [I][COLOR=seagreen]'green[/COLOR][/I]
        [COLOR=Royalblue]ElseIf[/COLOR] x > [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]Then[/COLOR]
        va(i, [COLOR=crimson]2[/COLOR]) = [COLOR=crimson]10921638[/COLOR] [I][COLOR=seagreen]'grey[/COLOR][/I]
    [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
[COLOR=Royalblue]Next[/COLOR]

[COLOR=Royalblue]Set[/COLOR] d = CreateObject([COLOR=brown]"scripting.dictionary"[/COLOR])
d.CompareMode = vbTextCompare
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR])
    d(va(i, [COLOR=crimson]1[/COLOR])) = va(i, [COLOR=crimson]2[/COLOR])
    [COLOR=Royalblue]Next[/COLOR]


[COLOR=Royalblue]Dim[/COLOR] shp [COLOR=Royalblue]As[/COLOR] Shape
      [COLOR=Royalblue]For[/COLOR] [COLOR=Royalblue]Each[/COLOR] shp [COLOR=Royalblue]In[/COLOR] ActiveSheet.Shapes([COLOR=brown]"Group 4"[/COLOR]).GroupItems
            [COLOR=Royalblue]If[/COLOR] d.Exists(shp.Name) [COLOR=Royalblue]Then[/COLOR]
            shp.Fill.ForeColor.RGB = d(shp.Name)
[I][COLOR=seagreen]'            Debug.Print shp.Name & " : " & d(shp.Name)[/COLOR][/I]
            [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
      [COLOR=Royalblue]Next[/COLOR] shp

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]

 

[Yongle]

This works for me
- see picture of worksheet for layout

with formula in C2 copied down
=IF(B2<0.9,"Red",IF(B2<0.95,"Orange",IF(B2<1.05,"Grey")))

Sub ColourShapes2()
    Dim shp As Shape, aMatch As Range, Rng As Range
    Set Rng = Sheets("LookUpSheet").Range("A:A")
    For Each shp In ActiveSheet.Shapes
            On Error Resume Next
            Set aMatch = Rng.Find(shp.Name).Offset(, 2)
            With shp.Fill.ForeColor
                Select Case aMatch
                    Case "Red":     .RGB = RGB(255, 0, 0)
                    Case "Orange":  .RGB = RGB(255, 100, G)
                    Case "Green":   .RGB = RGB(0, 0, 255)
                    Case "Grey":    .RGB = RGB(150, 150, 150)
                End Select
            End With
    Next shp
End Sub

Excel 2016 (Windows) 32 bit

	A​	B​	C​	D​	E​
1​	Name	Range	Colour	Formula
2​	Khyber	92%​	Orange	=IF(B2<0.9,"Red",IF(B2<0.95,"Orange",IF(B2<1.05,"Grey")))
3​	Bajour	102%​	Grey
4​	etc

Sheet: LookUpSheet

 

[naveeddil]

Unfortunately I have worked on it and nothing worked so until I got help from a youtube video https://www.youtube.com/watch?v=sgtHyk1cKk0 and then He helped me getting the code designed specific for my sheet.
The code that worked for me is below

Sub Fill_Color()

For i = 1 To 35 '35 regions in total

If Sheet1.Cells(4 + i, 3) < 0.9 Then
    Sheet1.Shapes.Range(Array(Sheet1.Cells(4 + i, 2))).Fill.ForeColor.RGB = RGB(255, 0, 0)

ElseIf Sheet1.Cells(4 + i, 3) >= 0.9 And Sheet1.Cells(4 + i, 3) <= 0.95 Then
    Sheet1.Shapes.Range(Array(Sheet1.Cells(4 + i, 2))).Fill.ForeColor.RGB = RGB(255, 192, 0)
    
ElseIf Sheet1.Cells(4 + i, 3) > 0.95 And Sheet1.Cells(4 + i, 3) <= 1 Then
    Sheet1.Shapes.Range(Array(Sheet1.Cells(4 + i, 2))).Fill.ForeColor.RGB = RGB(0, 176, 80)

ElseIf Sheet1.Cells(4 + i, 3) > 1 Then
    Sheet1.Shapes.Range(Array(Sheet1.Cells(4 + i, 2))).Fill.ForeColor.RGB = RGB(191, 191, 191)

End If

Next i

End Sub