VBA to immediately change the colour of a cell depending on the code placed in another cell!

[Phil Payne]

Hello,

Firstly please let me advise that standard conditional formatting will not work here as this requires ten conditions to be set.

I have a worksheet that contains 40 'paired' columns. In the first column of each pair I can enter any one of ten condition codes. The corresponding cell in the second of the paired columns needs to change its interior colour to that dictated by the code in the first of the pair.

I have tried a few ways without success with my last attempt almost making it where I used three named ranges and this code:

Dim conditions()
    ReDim conditions(1 To Range("conditions2use").Count)
    Dim i
    i = 1
    For Each cell In Range("conditions2use")
        conditions(i) = CInt(cell.Value)
        i = i + 1
    Next cell
 
    i = 1
    For Each cell In Range("data2use")
        Range("formats2use").Cells(conditions(i)).Select
        Selection.Copy
        cell.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        i = i + 1
    Next cell

Unfortunately this hit the limit on the number of separate columns I could place within one named range and the macro only ran through 4 of the paired columns - even if this had been successful it would still have been unsatisfactory as a macro had to be run to refresh the cells colours. I wish to have the colour change as the code is changed.

I hope someone in this forum has had a similar requirement in the past and can provide a solution.

I am using MS Excel 2003 SR3.

Thanks in anticipation.

 

[Phil Payne]

Hello,
I managed to solve the problem (with helP and thought I should post here for others to view.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim rCell As Excel.Range
Dim rCodes As Range
Dim vMatch

Set rCodes = Range("B2:B12")

If Not Intersect(Target, Range("O:O,R:R,U:U,X:X,AA:AA,AD:AD,AG:AG,AJ:AJ,AM:AM,AP:AP,AS:AS,AV:AV,AY:AY,BB:BB,BE:BE,BH:BH,BK:BK,BN:BN,BO:BO,BT:BT,BW:BW,BZ:BZ,CC:CC,CF:CF,CI:CI,CL:CL,CO:CO,CR:CR,CU:CU,CX:CX,DA:DA,DD:DD,DG:DG,DJ:DJ,DM:DM,DP:DP,DS:DS,DV:DV,DY:DY,EB:EB")) Is Nothing Then

For Each rCell In Intersect(Target, Range("O:O,R:R,U:U,X:X,AA:AA,AD:AD,AG:AG,AJ:AJ,AM:AM,AP:AP,AS:AS,AV:AV,AY:AY,BB:BB,BE:BE,BH:BH,BK:BK,BN:BN,BO:BO,BT:BT,BW:BW,BZ:BZ,CC:CC,CF:CF,CI:CI,CL:CL,CO:CO,CR:CR,CU:CU,CX:CX,DA:DA,DD:DD,DG:DG,DJ:DJ,DM:DM,DP:DP,DS:DS,DV:DV,DY:DY,EB:EB")).Cells

If Len(rCell.Value) > 0 Then

vMatch = Application.Match(rCell.Value, rCodes, 0)

If IsError(vMatch) Then

MsgBox "Invalid code selected"

Else

rCell.Offset(, 1).Interior.Color = rCodes.Cells(vMatch).Interior.Color

End If

End If

Next rCell

End If
End Sub