Lookup and match color of corresponding cell

[najisaadat]

Hello there,

I'm quite lost trying to figure out a simple solution to this. I have
simplified things to make things easier...

I have the following:

A B C D
1 (BLUE)
2 XY

The parantheses indicates the background color of the cell:

33 XX (RED)
34 XY (BLUE)
35 XZ (ORANGE)
36 XE (BLACK)

I need help in writing a program that will go through the range A22
and try to match any non blank cells with the legend definitions in
rows 33:36, and make the background color of the cell above it equal
to the color that was looked up. In this example, I want the result of
the program to make cell B1 BLUE, which is the background definition
in row 33:36 for XY.

Please help me! You will make my day!

 

[JLGWhiz]

See if this works for you:

Sub colorMe()
Dim srcRng As Range, ckRng As Range, Clr As Range
Set srcRng = ActiveSheet.Range("A33:A36")
Set ckRng = ActiveSheet.Range("A22")
For Each c In ckRng
Set Clr = srcRng.Find(c.Value, LookIn:=xlValues)
If Not Clr Is Nothing Then
Select Case Clr.Value
Case "XX"
c.Offset(-1, 0).Interior.ColorIndex = 3
Case "XY"
c.Offset(-1, 0).Interior.ColorIndex = 41
Case "XZ"
c.Offset(-1, 0).Interior.ColorIndex = 46
Case "XE"
c.Offset(-1, 0).Interior.ColorIndex = 1
End Select
End If
Next
End Sub

 

[najisaadat]

Thanks JLG for your help! It is much appreciated!!

This code would work great, except that the "XX", "XY" fields are
dynamic and not static. They are always changing so I need the code to
match the cells and their colors up regardless of what it is trying to
match up. So instead of the Case Statements it needs to look at
whatever is in the legend (rows 33:36) because the legend and
corresponding matches are always changing. Is this possible? Thanks a
bunch!!

 

[najisaadat]

Thanks for your help! I figured it out and did the following:

Sub colorMe2()
Dim srcRng As Range, ckRng As Range, Clr As Range
Set srcRng = ActiveSheet.Range("A33:A36")
Set ckRng = ActiveSheet.Range("A22")
For Each c In ckRng


Ship1 = Worksheets("Sheet2").Range("A33").Value
Ship2 = Worksheets("Sheet2").Range("A34").Value
Ship3 = Worksheets("Sheet2").Range("A35").Value



Set Clr = srcRng.Find(c.Value, LookIn:=xlValues)
If Not Clr Is Nothing Then
Select Case Clr.Value
Case Ship1
c.Offset(-1, 0).Interior.ColorIndex = 3
Case Ship2
c.Offset(-1, 0).Interior.ColorIndex = 41
Case Ship3
c.Offset(-1, 0).Interior.ColorIndex = 46
Case "XE"
c.Offset(-1, 0).Interior.ColorIndex = 1
End Select
End If
Next
End Sub

 

[Patrick Molloy]

am i missing something? your code looks rather complex, while I think ut
should be rather more trivial.
I included a check for empty cells. I didn't include a check for when the
cell content wasn't in the list ....but thats easy enough to add..

Option Explicit
Sub SetColors()
Dim cell As Range
For Each cell In Range("A22").Cells
If cell.Value <> "" Then
cell.Interior.Color =
Range("A33").Offset(WorksheetFunction.Match(cell.Value, Range("A33:A36"),
False) - 1).Interior.Color
End If
Next
End Sub