Change Colour

vmjan02

Well-known Member
Joined
Aug 15, 2012
Messages
1,132
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
I have the code below and just need to work it in correct way

this table below has the colour code in RGB it should fill the colour with respect to RGB , if the cell value is above 70 then RGB colour fill should be (0,176,80) and so on.

any help

1​
109.43​
RGB0,176,80Green color> 70
2​
105.826​
RGB146,208,80light green>55 - <=70
3​
103.195​
RGB255,0,0Red<55
5​
83.479​
6​
105.624​
7​
47.382​
8​
104.02​
9​
111.292​
10​
61.826​
11​
97.132​
12​
109.231​
13​
66.869​
14​
175.715​




VBA Code:
Sub fillcolor()

For I = 1 To 15
a = Sheet1.Cells(I + 1, 2) / 71 * 255
c = Sheet1.Cells(I + 1, 2) / 70 * 255
b = Sheet1.Cells(I + 1, 2) / 55 * 255

Sheet1.Shapes.Range(Array("Freeform " & I + 1)).Fill.ForeColor.RGB = RGB(a, c, b)
Next I


End Sub
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Run time error 1004

The Item with specified name wasn't found
Thanks. That indicates that the particular shape was not found. When you get the error, click Debug then hover over the variable 'i' in the code and that will indicate the particular problem.
For example, if i=3 then the code could not find the shape "Freeform 3"
 
Upvote 0

For my testing, I changed the loop For i = 1 to 3 since I only have 3 shapes.
This is the result after running the code. (Labels in column F are just for visual identification)

1692703738319.png
 
Upvote 0
Hi am sharing the screen shot
In some case its not taking the correct color.
Eg :- 105 should be green no 5 and 47.4 should be red no 6. cna this be fixed.

1692705289363.png


rest the code is working fine

VBA Code:
Sub fillcolor_v2()
  Dim i As Long
  Dim sRGB As String
  Dim vRGB As Variant
  
  'On Error Resume Next
  For i = 1 To 13
    Select Case Sheet1.Cells(i + 1, 2).Value
      Case Is <= 55: sRGB = "255,0,0"
      Case Is <= 70: sRGB = "146,208,80"
      Case Else: sRGB = "0,176,80"
    End Select
    vRGB = Split(sRGB, ",")
    Sheet1.Shapes.Range(Array("Freeform " & i)).Fill.ForeColor.RGB = RGB(vRGB(0), vRGB(1), vRGB(2))
  Next i
End Sub
 
Upvote 0
Can't tell much for sure from a screen shot and we cannot see your row numbers. From what we can see though it looks like Riyadh is in row 1 but the code starts processing from row 2 as I described earlier
I have assumed
  1. that the values to be checked actually start in B2 not B1 (fits more with your code from post 1)
If Riyadh is in row 1 then everything will be off by one row.
 
Upvote 0
Can't tell much for sure from a screen shot and we cannot see your row numbers. From what we can see though it looks like Riyadh is in row 1 but the code starts processing from row 2 as I described earlier

If Riyadh is in row 1 then everything will be off by one row.
Hi checked it it was to start from row no 2, and not 1. Now it is all perfect and correct.


Just need a help can we change the colour of the retangle share as will with respect to cell value.


Rich (BB code):
Sub fillcolor_v2()
  Dim i As Long
  Dim a As Long
  Dim sRGB As String
  Dim vRGB As Variant
 
 
'this is perfect and correct.
For i = 1 To 13
    Select Case Sheet1.Cells(i + 1, 2).Value
      Case Is <= 55: sRGB = "255,0,0"
      Case Is <= 70: sRGB = "146,208,80"
      Case Else: sRGB = "0,176,80"
    End Select
    vRGB = Split(sRGB, ",")
    Sheet1.Shapes.Range(Array("Freeform " & i)).Fill.ForeColor.RGB = RGB(vRGB(0), vRGB(1), vRGB(2))
  
    Next i
  
    'to chang the colour of rectangle
    For a = 1 To 2
    Select Case Sheet1.Cells(i + 1, 2).Value
      Case Is <= 55: sRGB = "255,0,0"
      Case Is <= 70: sRGB = "146,208,80"
      Case Else: sRGB = "0,176,80"
    End Select
    vRGB = Split(sRGB, ",")
   
    Sheet1.Shapes.Range(Array("Rectangle " & a)).Fill.ForeColor.RGB = RGB(vRGB(0), vRGB(1), vRGB(2))
    Next a


End Sub
 
Last edited by a moderator:
Upvote 0
If you want to bold part of your vba code, you need to use the RICH code tags, not the VBA tags. I have changed them for you.

I don't know what rectangles you are talking about or what you mean by "rectangle share".

Also, in what way is your code not working?
 
Upvote 0
Its insert shape Rectangle 1 and Rectangle 2,
That did not address these points.
.. what you mean by "rectangle share".
Also, in what way is your code not working?

However, I suspect that your problem is that in the second loop where you have used 'a' as the loop counter, you did not change all the 'i' counters to 'a'

1692750365270.png


If that was the issue then note that you could do without the second loop and deal with both types of shapes within the first loop.

VBA Code:
Sub fillcolor_v3()
  Dim i As Long
  Dim sRGB As String
  Dim vRGB As Variant
 
  For i = 1 To 13
    Select Case Sheet1.Cells(i + 1, 2).Value
      Case Is <= 55: sRGB = "255,0,0"
      Case Is <= 70: sRGB = "146,208,80"
      Case Else: sRGB = "0,176,80"
    End Select
    vRGB = Split(sRGB, ",")
    Sheet1.Shapes.Range(Array("Freeform " & i)).Fill.ForeColor.RGB = RGB(vRGB(0), vRGB(1), vRGB(2))
    If i <= 2 Then Sheet1.Shapes.Range(Array("Rectangle " & i)).Fill.ForeColor.RGB = RGB(vRGB(0), vRGB(1), vRGB(2))
  Next i
End Sub
 
Upvote 0
Solution
Thnaks man you are a life saver its all perfect and working fine. thanks bro.
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top