How can I force user to enter negative number in Excel?
Basically column A can only be "W" or "X". Whenever column A has "W", i want column B to reflect a negative number, even if the user has keyed in a positive number.
"W" in column A corresponds to a negative value in column B
"X" in column B corresponds to a positive value in column B.
Thanks for the help!
No VBA needed. Just use data validation with the following formula
=OR(AND(A1="W",B1<0),AND(A1="X",B1>0))
Image 1: Using data validation W in column A only allows negatives in column B, X in column A only allows positives in column B.
Install the code below in the code module of the worksheet on which you want to control the input. It's a module that already exists in your VB Project. Any module you have to create is the wrong one and won't work. Look for a module with a double name like Sheet1 (Sheet1).
Private Sub Worksheet_Change(ByVal Target As Range)
' 058
Dim Rng As Range
Dim Numb As Variant
Dim NewNumb As Double
' ignore changes to more than one cell (such as pasting)
If Target.CountLarge > 1 Then Exit Sub
' this range starts in A2 and covers all used cells in columns A:B
Set Rng = Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)) _
.Resize(, 2)
' skip if the changed cell is not within the defiend range
If Not Application.Intersect(Target, Rng) Is Nothing Then
' take no action of the value in column A isn't "X" or "W"
With Target
Numb = Cells(.Row, "B").Value
' take no action if the cell in column B has no value
If Numb Then
If Cells(.Row, "A").Value = "W" Then
NewNumb = Abs(Val(Numb)) * -1
ElseIf Cells(.Row, "A").Value = "X" Then
NewNumb = Abs(Val(Numb))
End If
' prevent changes made from calling this procedure
Application.EnableEvents = False
' don't take action if the value in column A
' was neither X nor W
If Numb And (Numb <> NewNumb) Then _
Cells(.Row, "B").Value = NewNumb
Application.EnableEvents = True
End If
End With
End If
End Sub
The code works on columns A and B. To modify these targets isn't difficult. For now, when a cell in either column is changed the procedure may take action. For the rules by which it will not take action please read the comments in the code. When it does take action it will make sure that any entry in column B is negative if the letter in column A is W and positive when it's X, regardless of what sign the user entered.
A little VBA in your worksheet module will take care of that:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const SourceColumn As Long = 1
Const TargetColumn As Long = 2
Const NegatorSymbol As String = "W"
Dim SourceRange As Excel.Range
Dim TargetRange As Excel.Range
Dim Sign As Long
Dim TargetValue As Long
If Target.Column = TargetColumn Then
Set SourceRange = Cells(Target.Row, SourceColumn)
If UCase(SourceRange.Value) = NegatorSymbol Then
Sign = -1
Else
Sign = 1
End If
TargetValue = Sign * Abs(Target.Value)
If Target.Value <> TargetValue Then
Target.Value = TargetValue
End If
ElseIf Target.Column = SourceColumn Then
Set TargetRange = Cells(Target.Row, TargetColumn)
If UCase(Target.Value) = NegatorSymbol Then
Sign = -1
Else
Sign = 1
End If
TargetValue = Sign * Abs(TargetRange.Value)
If TargetRange.Value <> TargetValue Then
TargetRange.Value = TargetValue
End If
End If
End Sub
You can set on column B a data validation Custom with this formula:
=OR(AND(A1="W";B1<0);AND(A1<>"W";B1>0))
[EDIT]
I was late to the party...
Related
I have an excel file, all the cells of the column A contain a value (numerical value), then there is the column B, which contains other values.
I would like to write a script in vba (or also other options, if there are alternatives) to control the change the values in column A.
To be clear, the excel user can change the cell A1 only if the cell B1 has a value equal to zero.
The same for the following rows, so the row A2 can be changed only if B2 is equal to zero, and so on.
I have searched on internet but I can't find a good solution, in particular because this must work on a large number of cells.
Thanks
Please, copy the next event code in the respective sheet code module, and play with changing:
Option Explicit
Private newVal
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.cells.count > 1 Then Exit Sub
If Target.column = 1 Then
If Target.Offset(, 1).Value <> 0 Then
Application.EnableEvents = False 'to avoind triggering again the Change event
newVal = Target.Value
Application.Undo
Application.EnableEvents = True
End If
End If
End Sub
You can use Data validation for this:
Select the range (ex: A1:A10)
Go to Data -> Data tools -> Data Validation
Choose the following options:
Allow "Custom"
Formula: =B1:B10=0
A Worksheet Selection Change: Restrict Column Access
With the current setup (A2, B), the following will allow access to column A (more accurately, to A2:A1048576) only if a single cell is to be selected and the cell in the same row of column B is equal to 0.
Optionally, if you choose the out-commented If statement, it will also allow access if the cell in column B is empty.
An empty cell is also numeric and equal to 0. It isn't of type Double though, but of type Empty.
Sheet Module e.g. Sheet1 (Not Into ThisWorkbook or Standard Module e.g. Module1)
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const TGT_FIRST_CELL As String = "A2"
Const SRC_COLUMN As String = "B"
Dim trg As Range
With Me.Range(TGT_FIRST_CELL)
Set trg = .Resize(Me.Rows.Count - .Row + 1)
End With
Dim irg As Range: Set irg = Intersect(trg, Target)
If irg Is Nothing Then Exit Sub
Dim ColumnOffset As Long
ColumnOffset = Me.Columns(SRC_COLUMN).Column - irg.Column
Dim srg As Range: Set srg = irg.Offset(, ColumnOffset)
If srg.Cells.Count = 1 Then
Dim sValue As Variant: sValue = srg.Value
If VarType(sValue) = vbDouble Then ' write just if 0
' or:
'If IsNumeric(sValue) Then ' write if 0 or empty
If sValue = 0 Then Exit Sub
End If
End If
srg.Cells(1).Select
End Sub
I know about conditional formatting, but it doesn't give me the options I'm looking for: namely, the possibility to manually change the cell fill color (in affected cells) based on how a color another cell, and with that, a standard fill color if I don't do anything. I have this VBA code for a single row (see below) and it works, though I have a feeling it's complicated in itself. Now, I want the same thing for another 149 rows, but the code obviously gets to complex. How can I achieve this? Is it wrong to put this in a SelectionChange?
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Cell As Range
For Each Cell In Range("F7:PB7")
If Cell.Value < Range("D8").Value Or Cell.Value > Range("E8").Value Then
Cell.Offset(1, 0).Interior.ColorIndex = 0
End If
If Cell.Value >= Range("D8").Value And Cell.Value <= Range("E8").Value Then
If Range("B8").Interior.ColorIndex < 0 Then
Cell.Offset(1, 0).Interior.ColorIndex = 15
Else
If Range("B8").Interior.ColorIndex >= 0 Then
Cell.Offset(1, 0).Interior.Color = Range("B8").Interior.Color
End If
End If
End If
... et cetera next row ...
Next Cell
End Sub
Best regards!
Try this out. I'm getting the default color for each row from ColA.
This is all in the worksheet code module:
Option Explicit
Const RW_DATES As Long = 7 'row with headers and dates
Const COL_NAME As Long = 2 'column with person's name
Const COL_START_DATE As Long = 4 'column with start date
Const COL_DATE1 As Long = 6 '1st date on header row
Const NUM_ROWS As Long = 150 'how many rows?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, rng As Range, rngDates As Range, i As Long
Dim startDate, endDate, rw As Range, arrDates, rngRowDates As Range
Dim CheckAll As Boolean, hiliteColor As Long, hiliteName As String
Dim cName As Range, selName, selColor As Long
CheckAll = Target Is Nothing 'called from selection_change?
If Not CheckAll Then
'Was a cell changed? see if any start/end date cells were changed
Set rng = Application.Intersect(Target, _
Me.Cells(RW_DATES + 1, COL_START_DATE).Resize(NUM_ROWS, 2))
If rng Is Nothing Then Exit Sub 'nothing to do in this case
Else
'called from Selection_change: checking *all* rows
Set rng = Me.Cells(RW_DATES + 1, COL_START_DATE).Resize(NUM_ROWS)
End If
Debug.Print "ran", "checkall=" & CheckAll
'header range with dates
Set rngDates = Me.Range(Me.Cells(RW_DATES, COL_DATE1), _
Me.Cells(RW_DATES, Columns.Count).End(xlToLeft))
arrDates = rngDates.Value 'read dates to array
Set cName = NameHiliteCell() 'see if there's a hilited name
If Not cName Is Nothing Then
selName = cName.Value
selColor = cName.Interior.Color
End If
'loop over each changed row
For Each rw In rng.EntireRow.Rows
Set rngRowDates = rw.Cells(COL_DATE1).Resize(1, rngDates.Columns.Count)
rngRowDates.Interior.ColorIndex = xlNone 'clear by default
startDate = rw.Cells(COL_START_DATE).Value 'read the dates for this row
endDate = rw.Cells(COL_START_DATE + 1).Value
'determine what color the bar should be
If Len(selName) > 0 And selName = rw.Cells(COL_NAME).Value Then
hiliteColor = selColor
Else
hiliteColor = rw.Cells(1).Interior.Color
End If
If startDate > 0 And endDate > 0 Then
i = 0
For Each c In rngRowDates.Cells
i = i + 1
If arrDates(1, i) >= startDate And arrDates(1, i) <= endDate Then
c.Interior.Color = hiliteColor
End If
Next c
End If
Next rw
End Sub
'just calls Worksheet_Change; add some delay to reduce frequency of firing
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static lastrun As Date
If lastrun = 0 Then lastrun = Now
If Now - lastrun > (1 / 86400) Then
lastrun = Now
Worksheet_Change Nothing
End If
End Sub
'find the first name cell which has any fill and return it
Function NameHiliteCell() As Range
Dim c As Range
For Each c In Me.Cells(RW_DATES + 1, COL_NAME).Resize(NUM_ROWS)
If Not c.Interior.ColorIndex = xlNone Then
Set NameHiliteCell = c
Exit Function
End If
Next c
End Function
My test range:
Would something like this be better? It will only fire when you change a value in the range F7:PB7.
It won't fire if the cell value is updated through a formula (for that you'd want to look at the cell that you changed to make the formula update).
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count = 1 Then 'Only fire if a single cell is changed.
If Not Intersect(Target, Range("F7:PB154")) Is Nothing Then
MsgBox Target.Address 'Test
'Your code - looking at Target rather than each Cell in range.
End If
End If
End Sub
Edit: Updated the range so it looks at more than one row, but now thinking I should delete the answer due to the odd/even rows that #Cyril indicates, etc.... this isn't looking like a complete answer now.
I have a worksheet with 3 rows and 7 columns (A1:G3).
A and B columns have 6 checkboxes (A1:B3). Boxes in columns A & B are linked to columns C & D respectively. Cells in columns E & F are just replicating columns C & D respectively (live E1 cell is =C1 and F3 cell is =D3).
I want to put a timestamp in cell G for each row when a checkbox is ticked or unticked by using Worksheet_Calculate event in VBA for that sheet.
My code works when used for just 1 row.
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
End Sub
I want to combine the code for 3 rows.
Here are 2 variations:
1st one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
Set cbX2 = Range("A2:F2")
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
ElseIf Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
ElseIf Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them with ElseIf like in the code above, a timestamp gets put in only G1, no matter if I tick B1 or C2.
2nd one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
Set cbX2 = Range("A2:F2")
If Not Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
End If
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them by ending each one with End If and start a new If, timestamp gets put in all of the G1, G2 and G3 cells, even if I tick just one of the boxes.
You seem to be confusing Worksheet_Calculate with Worksheet_Change and using Intersect as if one of the arguments was Target (which Worksheet_Calculate does not have).
Intersect(cbX1, Range("A1:F1")) is always not nothing because you are comparing six apples to the same six apples. You might as well ask 'Is 1,2,3,4,5,6 the same as 1,2,3,4,5,6?'.
You need a method of recording the values of your range of formulas from one calculation cycle to the next. Some use a public variable declared outside the Worksheet_calculate sub procedure; personally I prefer a Static variant array declared within the Worksheet_calculate sub.
The problem with these is initial values but this can be accomplished since workbooks undergo a calculation cycle when opened. However, it is not going to register Now in column G the first time you run through a calculation cycle; you already have the workbook open when you paste in the code and it needs one calculation cycle to 'seed' the array containing the previous calculation cycle's values.
Option Explicit
Private Sub Worksheet_Calculate()
Static vals As Variant
If IsEmpty(vals) Then 'could also be IsArray(vals)
vals = Range(Cells(1, "A"), Cells(3, "F")).Value2
Else
Dim i As Long, j As Long
With Range(Cells(1, "A"), Cells(3, "F"))
For i = LBound(vals, 1) To UBound(vals, 1)
For j = LBound(vals, 2) To UBound(vals, 2)
If .Cells(i, j).Value2 <> vals(i, j) Then
Application.EnableEvents = False
.Cells(i, "G") = Now
Application.EnableEvents = True
vals(i, j) = .Cells(i, j).Value2
End If
Next j
Next i
End With
End If
End Sub
I have some people, whose working time are shown by the conditional formatting in the cells on their own columns - e.g. B7:B36, C7:C36, D7:D36 and so. I try to count the conditional formatting cells to the column E. The end result in the cell is #Value (Arvo), but when you press F9, then the numbers can be displayed.
When I run the code step by step, I noticed that after the line "Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats program jump to function "Function CountRed(MyRange As Range" and stay in the Loop for some time.
Is this because that there is a function "CountRed(B6)+CountGreen(C6)+CountBlue(D6)" for example in the cell E6?
In addition, I would like the column numbers in column E are concentrated in the central.
Error if exit time is empty:
Result with error in col E:
Results should look like this:
The original code can be also found here - Thanks Floris!
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
If Not Intersect(target, Range("B4:Q4")) Is Nothing Then
'Sub makeTimeGraph()
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 0.000001 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim Jim
Dim Mark
Dim Lisa
Dim nameCols As Range
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats
Application.ScreenUpdating = False
' loop over each of the columns:
For Each c In timeCols.Cells
Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
'select format range
formatRange.Select
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange1(formatRange) ' Red Colorinex 3
Case "Mark"
Call formatTheRange2(formatRange) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange3(formatRange) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Private Sub formatTheRange1(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color red coloroindex 3
With r.Interior
.Pattern = xlSolid
.ColorIndex = 3
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange2(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Green Colorindex 4
With r.Interior
.Pattern = xlSolid
.ColorIndex = 4
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange3(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Blue Colorindex 5
With r.Interior
.Pattern = xlSolid
.ColorIndex = 5
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Function CountRed(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 3 Then
i = i + 1
End If
Next cell
CountRed = i
End Function
Function CountGreen(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 4 Then
i = iCount + 1
End If
Next cell
CountGreen = i
End Function
Function CountBlue(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 5 Then
i = i + 1
End If
Next cell
CountBlue = i
End Function
The #VALUE!(ARVO) error could be overcome by adding ws.Calculate to the end of your Private Sub worksheet_change(ByVal target As Range) procedure.
That said, your desired outcomes:
Graphic representation of time being worked by employees
How many people are working during different time intervals
Can be accomplished using conditional formatting in columns B:D and COUNTIFS functions in column E.
To set up the conditional format in column B:
Select from B6 down to the cell adjacent to the last time in column A
Click Conditional Formatting and click on the "Use a formula..." option
Enter =AND(A6>=B$4,$A6<B$5) in the formula box
Click the Format.. button and select Fill colour
Click OK
Click Apply or OK to see the result or close the dialogue
You can copy the conditional formats to columns C and D then edit their fill colours as desired.
In cell E6 inter the formula:
=COUNTIFS(A6,">="&B$4,A6,"<"&B$5)
+COUNTIFS(A6,">="&C$4,A6,"<"&C$5)
+COUNTIFS(A6,">="&D$4,A6,"<"&D$5)
Copy from B6 down to E last time row into F6; J6 etc.
By not using VBA at all you will improve worksheet performance. It's usually better to use Excel functionality and built-in functions where possible and reserve VBA to do repetitive tasks and create UDFs to calculate thing that can't be done using built-in functions.
Hyvää päivää! It's me again… Good to see you are continuing to improve your code. I have made a few tweaks to make it work a bit better. In particular:
Modified the test of the Target - so it will update both when you change the start time, and when you change the end time. You were only doing things when the start time was changed.
Just one formatting function instead of 3, with a second parameter (color). This keeps the code a little tidier. You could even have a dictionary of key/value pairs - but that doesn't work on a Mac which is where I'm writing this so I won't show you.
Hidden inside the colored cell is the number 1, with the same color as the background (hence "invisible") - this is added by the formatting function
Now your "sum" column can just contain a SUM(B6:D6) style formula that you copy down the column. This is considerably faster than three custom functions that check for the color in the cells to their left… (removed those functions from the code)
Have to clear the entire column's values (not just formatting) to remove any 1s left over from a previous run; this is done in the per-column loop (rather than all at once) to preserve the SUM() formulas in the "per day" columns.
Nothing is ever selected by the code - so there's nothing to unselect at the end; this means that the selection doesn't jump to the A1 cell every time you make an edit.
Removed the Dim Jim etc statements since you did not use those variables.
Now that the code is modifying the sheet (changing the values in cells by adding the invisible ones) there is a risk of things really slowing down (every change causes the event to fire again) - so I am turning off the events when you enter the function, and turn them on again when you leave (using Application.EnableEvents = False or True respectively); to be safe, errors are also trapped (with On Error GoTo whoops) - these send your code straight to the "enable events and exit function" part of the code.
Presumably you have figured out that this code needs to live in the worksheet code (rather than a regular module) in order to receive the events properly.
Here is the new code:
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
On Error GoTo whoops
If Not Intersect(target, Range("B4:Q5")) Is Nothing Then
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 1e-06 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim nameCols As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous values and formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats
' loop over each of the columns:
For Each c In timeCols.Cells
'Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
' get rid of any values currently in this row:
timeRange.Offset(0, c.Column - 1).Clear
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange(formatRange, 3) ' Red Colorindex 3
Case "Mark"
Call formatTheRange(formatRange, 4) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange(formatRange, 5) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
whoops:
If Err.Number > 0 Then
MsgBox "error: " & Err.Description
Err.Clear
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, c)
Dim cc
' Apply color c
With r.Interior
.Pattern = xlSolid
.ColorIndex = c
End With
r.Font.ColorIndex = c
' put an invisible 1 in each cell:
For Each cc In r.Cells
cc.Value = 1
Next
End Sub
Here's how things look (just one set of columns showing - but this should work fine in your multi-column version):
I am not a fan of writing macro, unless you exhausted the capabilities of Excel. Instead of attacking the problem through the ColorIndex, go back to the source of your data. Use this formula on E6
{=SUM(($B$4:$D$4<=A6)*($B$5:$D$5>A6))}
Remember to use Ctrl+Shift+Enter to enable the array function, instead of just Enter. Paste down and it will perform the behavior you are aiming for.
I want to highlight excel sheet cell (Column 'A') of when it does not contain the text like "Verify", "Validate" or "Evaluate" in its content if, the value in corresponding cell of Column 'B' holds the value 'Y'.
When the column 'A' can't contains the words like 'Verify', 'Validate' and 'Evaluate' if the corresponding cell in Column 'B' holds value 'N'. So just need to highlight those discrepancies if its there.
Column 'A': Press Enter and verify this and this...
Column 'B': Y
This is quick example. However, the second formula can be shorted in case that column B cannot be blank. See if this fits ...
EDIT:
Here is VBA example as requested. You will need to save the code into current sheet (example: Sheet1 )...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim str As String
Dim lCol As Long
Dim oCell As Object
Dim oCellFormat As Object
lCol = Target.Column
If lCol = 1 Or lCol = 2 Then
Set oCell = Cells(Target.Row, 1)
Else
GoTo mExit
End If
str = UCase(oCell.Value)
Set oCellFormat = Cells(oCell.Row, 1)
If (str = "VERIFY" Or str = "VALIDATE" Or str = "EVALUATE") Then
If UCase(Cells(oCell.Row, 2).Value) = "N" Then
oCellFormat.Interior.ColorIndex = 3 'red
ElseIf UCase(Cells(oCell.Row, 2).Value) = "Y" Then
oCellFormat.Interior.ColorIndex = 4 'green
Else
oCellFormat.Interior.ColorIndex = 2 'white
End If
Else
oCellFormat.Interior.ColorIndex = 2 'white
End If
GoTo mExit
Exit Sub
mExit:
Set oCell = Nothing 'free resources
Set oCellFormat = Nothing
End Sub