CELL FORMATTING

[Keebler]

is there a vba code that will change the formatting of a cell (cell background color, font color, etc) based on what color name the cell has in it, referencing a range?

for example
in cell G2:G20 I have a range of colors (RED, BLU, BLK, GRN, etc)
in another sheet (data) in range a5:e20 I have a vlookup table
col1 has the short name (3 letter - RED, BLU, GRN, etc)
col 2 has the full name (RED, BLU, GREEN, YELLOW, ETC)
col 3,4,5 have the RGB CODES (red, grn, blu)

 

[John_w]

You haven't specified the sheet name of the G2:G20 cells, so this macro expects that sheet to be the active sheet.

Public Sub Format_Cells()

    Dim lookupTable As Range
    Dim cell As Range
    Dim dataRow As Variant
    
    Set lookupTable = Worksheets("Data").Range("A5:E20")
    
    For Each cell In ActiveSheet.Range("G2:G5")
        dataRow = Application.Match(cell.Value, lookupTable.Columns(1), 0)
        If Not IsError(dataRow) Then
            cell.Interior.Color = RGB(lookupTable.Item(dataRow, 3).Value, lookupTable.Item(dataRow, 4).Value, lookupTable.Item(dataRow, 5).Value)
        End If
    Next
    
End Sub

 

[Keebler]

would it be fair to assume that adding on_change to the header would result in every time the worksheet changes (there is no name other than sheet 1 (or active sheet)) the vba code would run?
the active sheet range is g5:g20 ( easy enough to do here)
thank you, this looks right up the alley. ill try it out later tonight or tomorrow when i get back home --- thank you

 

[Keebler]

the code works GREAT - thank you again

 

[Keebler]

Private Sub Format_Cells()

Dim lookupTable As Range
Dim cell As Range
Dim dataRow As Variant

Set lookupTable = Worksheets("Data").Range("A5:E20")

For Each cell In ActiveSheet.Range("G5:G70")
dataRow = Application.Match(cell.Value, lookupTable.Columns(1), 0)
If Not IsError(dataRow) Then
cell.Interior.Color = RGB(lookupTable.Item(dataRow, 3).Value, lookupTable.Item(dataRow, 4).Value, lookupTable.Item(dataRow, 5).Value)
End If
Next

End Sub



what would i need to include in the vlookup table for the backgrounds that are too dark? i want to make the font on only these cells white. the others can remain black

thank you again

20240714 FCC maping.xlsm
	G	H
4
5	WHT
6	BLK
7	GRN
8	BLU
9	YEL
10	RED
11
12
13	ORG	WHITE
14	YEL
15	GRY
16	GRN
17	RED
18	BLU
19	VIO
20	BRN
21	ORG	BLACK
22	YEL
23	GRY
24	GRN
25	RED
26	BLU
27	VIO
28	BRN
29	LTBLU
30	LTGRN
31	GRY
32
Sheet1

 

[Keebler]

so, i took what you did and added a few more columns to the vlookup table and added a font color row

Private Sub Format_Cells()

Dim lookupTable As Range
Dim cell As Range
Dim dataRow As Variant

Set lookupTable = Worksheets("Data").Range("A5:L20")

For Each cell In ActiveSheet.Range("G5:J70")
dataRow = Application.Match(cell.Value, lookupTable.Columns(1), 0)
If Not IsError(dataRow) Then
cell.Interior.Color = RGB(lookupTable.Item(dataRow, 3).Value, lookupTable.Item(dataRow, 4).Value, lookupTable.Item(dataRow, 5).Value)
cell.Font.Color = RGB(lookupTable.Item(dataRow, 10).Value, lookupTable.Item(dataRow, 11).Value, lookupTable.Item(dataRow, 12).Value)
End If
Next

End Sub

20240714 mapingv2.xlsm
	G
5	WHT
6	BLK
7	GRN
8	BLU
9	YEL
10	RED
11
12
13	ORG
14	YEL
15	GRY
16	GRN
17	RED
18	BLU
19	VIO
20	BRN
21	ORG
22	YEL
23	GRY
24	GRN
25	RED
26	BLU
27	VIO
28	BRN
29	LTBLU
30	LTGRN
31	GRY
Sheet1

 

[John_w]

so, i took what you did and added a few more columns to the vlookup table and added a font color row

Here's another approach you could consider. Instead of 6 columns for the RGB fill colour and font colour for each short name, you could have 1 cell formatted with the required fill and font colours for each short name:

Loop rows lookup table set cell colour.xlsm
	A	B	C
4	Short Name	Full Name	Font
5	RED	RED	XXXX
6	BLU	BLUE	XXXX
7	GRN	GREEN	XXXX
8	YEL	YELLOW	XXXX
Data

The macro now uses the Format Painter to copy each 'Font' cell format (which could include any font setting such as underline and borders) and paste it to each destination cell.

Public Sub Format_Cells2()

    Dim lookupTable As Range
    Dim cell As Range
    Dim dataRow As Variant
    
    Set lookupTable = Worksheets("Data").Range("A5:C8")
    
    For Each cell In Worksheets("Sheet1").Range("G2:G5")
        dataRow = Application.Match(cell.Value, lookupTable.Columns(1), 0)
        If Not IsError(dataRow) Then
            lookupTable.Item(dataRow, 3).Copy
            cell.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next
    Application.CutCopyMode = False
    
End Sub