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

Phil Payne · #1 06-12-2013, 02:12 PM

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:

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

BobBridges · #2 07-25-2013, 06:14 PM

Hi, Phil. I came here more than a month later to ask a question myself, and thought I'd look over some of these. I'm sorry no one has offered you what seems to me an obvious solution: Have you tried using a macro that runs automatically whenever any value on that worksheet has changed?

In general, VBA programs that are triggered by events in Office apps are named <Object-name>_<Eventname>, for example "Button1_Click" or "Form_Open". In this case you want, I think, "Worksheet_Change", like this:

Private Sub Worksheet_Change(ByVal ChangedCell As Range)
MsgBox "You put a new value in some cell on row " & ChangedCell.Row & "."
End Sub

You must include the specified parm as listed above, though you can name it whatever you like. You put this code not in a regular code module but in the code for the related worksheet. After that, whenever you enter a value on that worksheet, Excel will set your argument to the the cell object that was changed, and run the program.

In this case you want your program to check the address of the changed cell. If it's not column A then just Exit Sub without comment, and the user will never be bothered with it. Otherwise set the adjacent cell based on the new value in the changed cell. Clear?

Whenever I test this, I discover some pesky reason why the macro won't fire, and it's always some reason I forgot about since the last time I did this kind of thing. (I don't have to do it very often, so I forget each time.) Let me know if you have trouble of that kind, and I'll try to find an article listing some of the obvious reasons. Just now it turned out Application.EnableEvents was set to False for some reason; I just turned it back on and it worked great.

Phil Payne · #3 07-27-2013, 11:04 PM

Hello Bob,

I did find a solution for this, but as soon as I did the requirement changed and I haven't had time to return and post the solution.

The solution was as you said, by use of an 'worksheet change' macro:-

Code:

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

This method (took a while to set up) and had a limit on the number of columns I could reference. I've just found another solution to allow the range of columns to be extended beyond that limitation:

Code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' This code checks for a change of Status in the Status column and
'   on change fills the adjacent Cost cell with appropriate colour then
'   enters current date into the adjacent Date cell.
' The range covered extends from column ‘R’ (first Status column), to column ‘EZ’ (last Status column).
' If adding columns adjust ranges accordingly!

    If Target.Count > 1 Then Exit Sub
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Dim rCell As Range
    Dim rCodes As Range
    Dim rRow As Range
    Dim vMatch
    Set rCodes = Range("E2:E12")
    If (Target.Column >= 18) And (Target.Column <= Range("EZ1").Column) And (Target.Column Mod 3 = 0) Then
        If Len(Target.Value) > 0 Then
            On Error Resume Next
            vMatch = Application.Match(Target.Value, rCodes, 0)
            If IsError(vMatch) Then
                MsgBox "Invalid code selected"
            Else
                With Target
                    .Offset(, 1).Interior.Color = rCodes.Cells(vMatch).Interior.Color
                    .Offset(0, 2).Value = Date
                End With
            End If
        End If
    End If
End Sub

I'd like to thank you for taking the time and effort to help me with this!

Best regards.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Quadrant colour based on cell value	RoyLittle0	Excel	2	05-05-2013 12:50 AM
Change font colour when tasks are completed	meileetan	Project	3	09-12-2012 07:09 AM
Change Colour Theme in Word with VBA	Davidoff78	Word VBA	1	06-28-2012 05:23 PM
CHange colour of footer if a cell changes to red	OTPM	Excel	0	05-26-2011 07:15 AM
contacts email by colour code	mikemans	Outlook	0	10-31-2009 01:47 AM