VBA Conditional Formatting Colour Coded Custom List

[adamhoff]

Hi everyone, I could not find a solution for this.

On Sheet 1 I have a table such as this:

Vehicle Car	Colour Code Red
Bicycle	Blue
Tricycle	Yellow
Motorcycle	Yellow
Train	White
Plane	Green
Boat	Aqua

<colgroup><col><col></colgroup><tbody>
</tbody>

On Sheet 2 I have another table such as this:

Vehicle	Cost	Rental	Tickets
Motorcycle	25000	Yes	No
Plane	2000000	No	Yes
Bicycle	200	Yes	No
Car	50000	Yes	Yes

<colgroup><col><col span="3"></colgroup><tbody>
</tbody>

I am looking for a VBA code which will look up the colour code in sheet 1, and apply the colour listed to the cell fill colour under each cell in the Vehicle column of sheet 2.

I have used VBA for conditional formatting, but with very few criteria, in my real example, there may be up to two dozen different "vehicles" in the colour code sheet.

Thanks for any help getting this in the right direction.

 

[Joe4]

Welcome to the Board!

Here is one way of doing it. Add a third column to your table on Sheet1 that has the VBA color code you want to use.
You can easily get these by turning on the Macro Recorder, and recording yourself changing the fill color of a cell.
You will get code that looks something like this:

Sub Macro1()
'
' Macro3 Macro
'

'
    Range("C2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = [COLOR=#ff0000][B]255[/B][/COLOR]
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

Note the number listed after ".Color = ". This is the number you want to put in that third column.

Then, I find it easiest to name this three column range. In this example, I am naming it "rngColor".
To see how to name ranges, look here: https://www.contextures.com/xlNames01.html

Then, assuming that your data on Sheet2 starts in the upper left corner (cell C1), here is the VBA code you can use to color those rows:

Sub MyColorMacro()

    Dim lr As Long
    Dim r As Long
    Dim ccode As Long
    
    Sheets("Sheet2").Activate
    
'   Find last row in column A on Sheet2
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through all cells in column A on Sheet2, starting at row 2
    For r = 2 To lr
'       Look up color code
        ccode = Evaluate("VLookup(" & Cells(r, 1).Address & ", rngColor, 3, 0)")
'       Apply color to whole row
        Rows(r).Interior.Color = ccode
    Next r

End Sub

This should do what you want when you run it.