Fill color based on RGB

[ADK]

A beginner at this vba stuff. Looking to color a cell based on RGB values

Column A has the R numbers
Column B has the G numbers
Column C has the B numbers
Column D will be the where the cells fill color is based on the values
entered in columns A thru C. I'll have 256 rows ...each row will end up
having a different fill color based on the values

Example

A1=255
B1=255
C1=0
D1={cell fill color would be yellow}

A2=255
B2=191
C2=0
D2={cell fill color would be orange}

Thanks in advance for your help!

ADK

 

[Mike H]

Maybe this,

Right click the sheet tab, view code and paste this in and run it

Sub stantive_agreement()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set myrange = Range("A1:A" & lastrow)
For Each c In myrange
red = c.Value
green = c.Offset(0, 1).Value
blue = c.Offset(0, 2).Value
c.Offset(0, 3).Interior.Color = RGB(red, green, blue)
Next
End Sub


Mike

 

[Peter T]

ADK, how many unique colours do you envisage (envision) you will need in
total in the workbook.

Mike, the approach you suggested applies the 'nearest' RGB that already
exists in the palette. IOW one of the existing palette colours will be
applied, of which there are 46 in a default palette.

Regards,
Peter T

 

[Mike H]

I'm aware of that and so I assumed was the OP who said different colour based
on the RGB values not unique based on those values

Mike

 

[ADK]

What I would like to do is take the colors from AutoCAD (ACI) and create a
layer color table with a color sample in a cell. There are 256 colors in
autocad so to answer your question, 256. I am working on converting AutoCAD
Color Index (ACI) into RGB numbers.

 

[Jon Peltier]

What version of Excel are you using. Excel 2003 and earlier had access to a
palette of only 56 colors. You could select any RGB for these 56, but you
got no more colors than these. (You can use more colors to format shapes in
the worksheet, so if you just want to display different colors, you could
use rectangles or other shapes as the tiles in your display, rather than
cells.)

Excel 2007 allows all 256^3 colors, but in itself that's not enough
justification to upgrade.

- Jon

 

[Peter T]

In pre-XL2007 you are limited to 56 unique palette colours which can be
customized, hence why I
asked how many unique colours you might require.
There's no limit to unique RGB's in shapes on a sheet (subject resources).
Following adds shapes, if don't already exist, sized to cells in the fourth
column and
fills with the RGB.

Try "Test" on a new sheet

Sub Test()

With Range("A2:c500")
.Formula = "=INT(RAND()*255)"
.Value = .Value
End With

MultiRGBs
End Sub

Sub MultiRGBs()
Dim i As Long
Dim nCol As Long
Dim sName As String
Dim vArr3, vArr1
Dim rng As Range, cell As Range
Dim shp As Shape

'part1
'write the long RGB colour values in Col-D

' assumes first red-value is in A2, with green & blue in B2:C2
Set rng = Range("A2")
Set rng = Range(rng, _
Cells(Cells(65536, rng.Column).End(xlUp).Row, rng.Column))

vArr3 = rng.Resize(, 3).Value
ReDim vArr1(1 To UBound(vArr3), 1 To 1)

For i = 1 To UBound(vArr3)
vArr1(i, 1) = RGB(vArr3(i, 1), vArr3(i, 2), vArr3(i, 3))
Next
rng.Offset(, 3).Value = vArr1



' part 2
' if shape name clr&cell-ref doesn't exist add it
' fill the RGB with the long colour value in the cell in col-D

'ActiveSheet.Rectangles.Delete 'start with fresh shapes

'Application.ScreenUpdating = False

' Set rng = Range("A2")
' Set rng = Range(rng, _
' Cells(Cells(65536, rng.Column).End(xlUp).Row, rng.Column))

nCol = rng(1).Column + 3

With ActiveSheet.Shapes
For i = rng.Rows(1).Row To rng.Rows.Count + rng.Rows(1).Row - 1
Set cell = Cells(i, nCol)
sName = "clr" & cell.Address(0, 0)

Set shp = Nothing
On Error Resume Next
Set shp = .Item(sName)
On Error GoTo 0

If shp Is Nothing Then
Set shp = .AddShape(1, cell.Left, cell.Top, _
cell.Width, cell.Height)
shp.Name = sName
End If

With shp.Fill.ForeColor
If .RGB <> cell Then .RGB = cell
End With
Next
End With
Application.ScreenUpdating = True

End Sub


I separated the above into two parts for demo purposes.

Instead of "part1" you could use this formula filled down.
=(r + g*256 + b*256*256)

A Worksheet change event could change the filled RGB colour if any r, G or B
value changes (adapt the above into the change event).

It's quite a bit more complicated but it's also possible to scatter UDF's in
cells to be filled with unique RGB's (goes against UDF rules!).

Regards,
Peter T

 

[ADK]

We are currently using Excel 2000

In pre-XL2007 you are limited to 56 unique palette colours which can be
customized, hence why I
asked how many unique colours you might require.
There's no limit to unique RGB's in shapes on a sheet (subject
resources).
Following adds shapes, if don't already exist, sized to cells in the
fourth
column and
fills with the RGB.

Try "Test" on a new sheet

Sub Test()

With Range("A2:c500")
.Formula = "=INT(RAND()*255)"
.Value = .Value
End With

MultiRGBs
End Sub

Sub MultiRGBs()
Dim i As Long
Dim nCol As Long
Dim sName As String
Dim vArr3, vArr1
Dim rng As Range, cell As Range
Dim shp As Shape

'part1
'write the long RGB colour values in Col-D

' assumes first red-value is in A2, with green & blue in B2:C2
Set rng = Range("A2")
Set rng = Range(rng, _
Cells(Cells(65536, rng.Column).End(xlUp).Row, rng.Column))

vArr3 = rng.Resize(, 3).Value
ReDim vArr1(1 To UBound(vArr3), 1 To 1)

For i = 1 To UBound(vArr3)
vArr1(i, 1) = RGB(vArr3(i, 1), vArr3(i, 2), vArr3(i, 3))
Next
rng.Offset(, 3).Value = vArr1



' part 2
' if shape name clr&cell-ref doesn't exist add it
' fill the RGB with the long colour value in the cell in col-D

'ActiveSheet.Rectangles.Delete 'start with fresh shapes

'Application.ScreenUpdating = False

' Set rng = Range("A2")
' Set rng = Range(rng, _
' Cells(Cells(65536, rng.Column).End(xlUp).Row, rng.Column))

nCol = rng(1).Column + 3

With ActiveSheet.Shapes
For i = rng.Rows(1).Row To rng.Rows.Count + rng.Rows(1).Row - 1
Set cell = Cells(i, nCol)
sName = "clr" & cell.Address(0, 0)

Set shp = Nothing
On Error Resume Next
Set shp = .Item(sName)
On Error GoTo 0

If shp Is Nothing Then
Set shp = .AddShape(1, cell.Left, cell.Top, _
cell.Width, cell.Height)
shp.Name = sName
End If

With shp.Fill.ForeColor
If .RGB <> cell Then .RGB = cell
End With
Next
End With
Application.ScreenUpdating = True

End Sub


I separated the above into two parts for demo purposes.

Instead of "part1" you could use this formula filled down.
=(r + g*256 + b*256*256)

A Worksheet change event could change the filled RGB colour if any r, G or
B
value changes (adapt the above into the change event).

It's quite a bit more complicated but it's also possible to scatter UDF's
in
cells to be filled with unique RGB's (goes against UDF rules!).

Regards,
Peter T

 

[Peter T]

We are currently using Excel 2000

Er, OK.

As it happens the routine I posted was written in Excell 2000.

Not sure what you are trying to convey.

Regards,
Peter T

 

[ADK]

Thanks Peter, was able to use the routine to produce the color index

 

[ADK]

Peter,

The routine places a value in the cells of column D. If I transfer those
numbers to a different sheet, would would the routine be using those numbers
rather than the RGB values in columns A,B & C?

Thanks

ADK

 

[ADK]

Sorry, "different sheet, would would the routine" should read "different
sheet, what would the routine"

 

[Peter T]

"Those numbers" are the long-rgb colour values calculated from the
individual RGB attributes. You can use VBA's RGB() function or the formula I
suggested in the earlier post.

It's not necessary to dump those values into cells at all, VBA could
calculate colour-values from individual RGB's and format the (newly created)
shapes with the value temporarily held in memory. However, its probably
better for your purposes to stick with the intermediate step of placing the
values in cells then reading back those values.

In summary, the colour-values can exist anywhere, in memory or some cells,
the shapes do not necessarily need to be placed 'over' those values in
cells, but again probably best to do it that way until you are more familiar
with how to adapt the code for your own purposes.

Following assumes the colour-values are placed in a column of cells in some
sheet. Change the Sheet name and top cell address to suit. The sheet does
not need to be active. The workbook should be active unless to change
'activeworkbook.' to Workbooks("Bookname.xls").

Sub RGBsToShapes()
Dim i As Long
Dim nCol As Long
Dim sName As String
'Dim vArr3, vArr1 ' not used in this routine
Dim rng As Range, cell As Range
Dim ws As Worksheet
Dim shp As Shape


' Place a Shape(Rectangle) over the cell (if it doesn't already exist)
' Size the shape to the cell
' Fill the Shape with the long-rgb colour value in the cell.
' long-rgb colour values should be between >=0 to <=16777215

' ActiveSheet.Rectangles.Delete 'start with fresh shapes

'Application.ScreenUpdating = False

Set ws = ActiveWorkbook.Worksheets("Sheet3") ' < change
Set rng = ws.Range("G2") ' < change

With ws
Set rng = .Range(rng, _
.Cells(.Cells(65536, rng.Column).End(xlUp).Row,
rng.Column))
End With

nCol = rng(1).Column

With ws.Shapes
For i = rng.Rows(1).Row To rng.Rows.Count + rng.Rows(1).Row - 1
Set cell = ws.Cells(i, nCol)

If Len(cell) Then
sName = "clr" & cell.Address(0, 0)

Set shp = Nothing
On Error Resume Next
Set shp = .Item(sName)
On Error GoTo 0

If shp Is Nothing Then
Set shp = .AddShape(1, cell.Left, cell.Top, _
cell.Width, cell.Height)
shp.Name = sName
End If

With shp.Fill.ForeColor
If .RGB <> cell Then .RGB = cell
End With
End If
Next
End With
Application.ScreenUpdating = True

End Sub


Regards,
Peter T