View Single Post
 
Old 07-27-2013, 11:04 PM
Phil Payne Phil Payne is offline Windows XP Office XP
Novice
 
Join Date: Apr 2013
Location: Glasgow, Scotland
Posts: 5
Phil Payne is on a distinguished road
Default

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.
Reply With Quote