View Single Post
  #13   Report Post  
Posted to microsoft.public.excel.programming
Peter T Peter T is offline
external usenet poster
 
Posts: 5,600
Default Fill color based on RGB

"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


"ADK" wrote in message
...
Sorry, "different sheet, would would the routine" should read "different
sheet, what would the routine"



"ADK" wrote in message
...
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

"Peter T" <peter_t@discussions wrote in message
...
"ADK" wrote
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