Auto Colour of Cells

[WILFY06]

Dear All....

I know that this is possible as have seen it before, but using a defined table as ColourKey i want to create a macro that looks at the spreadsheet in given cell area, and then colours cells according to their names from the colourkey, any help would be appreciated... this is how far i've got prob wrong.

Sub ColourKey()
' Auto Colours Cells Using for Rota System and Holiday Maps

Dim ColourKey as

End Sub

Yeah i know not far eh!! lol

Kind Regards,
David

 

[wavemehello]

what will be the content in the cell? name of color?

 

[WILFY06]

will be names so David is assigned red as in the table and Susan is Blue, something like that? don't know if text has to be in the colour or next to it?
Thanks
David

 

[WILFY06]

This one seemed to have tricked a few people, so contacted guy i know and found answer!! all credit to him so take a bow STUART DIXON..

'Written by Stuart Dixon
Sub ColourThisIn()
Dim TextArray() As String
Dim ColourArray() As Long
Dim ArrayCount As Integer
Dim MaxRows As Long
Dim MaxCols As Long
Dim RowCount As Long
Dim ColCount As Long

'pick up the colours from the spreadsheet
Range("ColourKey").Select
ActiveCell.Offset(1, 0).Select
ArrayCount = 0
While ActiveCell.Value <> ""
ReDim Preserve TextArray(ArrayCount)
ReDim Preserve ColourArray(ArrayCount)
TextArray(ArrayCount) = ActiveCell.Value
ColourArray(ArrayCount) = ActiveCell.Interior.ColorIndex
ActiveCell.Offset(1, 0).Select
ArrayCount = ArrayCount + 1
Wend
'go through each cell & change the colour is applicable
ActiveCell.SpecialCells(xlCellTypeLastCell).Select
MaxRows = ActiveCell.Row
MaxCols = ActiveCell.Column
For RowCount = 1 To MaxRows
For ColCount = 1 To MaxCols
For ArrayCount = LBound(TextArray) To UBound(TextArray)
If Cells(RowCount, ColCount).Value = TextArray(ArrayCount) Then
With Cells(RowCount, ColCount).Interior
.ColorIndex = ColourArray(ArrayCount)
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
Next ArrayCount
Next ColCount
Next RowCount
Range("ColourKey").Select
End Sub