How can I optimize this code in Excel VBA? - excel

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.

Related

Is there a better way to get the value of the first cell that is centered across selection for the current cell?

Given that I am told we should be using Centered Across Selection instead of Merged Cells, I need to get the underlying value that is displayed across the cells when formatted as Centered Across Selection.
When using Merged Cells, it was easy:
CellValue = rng.MergeArea.Cells(1, 1).Value
Is there an easy way to get the same for Centered Across Selection, other than searching backwards while HorizontalAlignment = xlHAlignCenterAcrossSelection until the Cell Value <> "". My code to do this would be:
Function GetCenteredAcrossSelectionCellValue(rng As Range) As Variant
Dim i As Long
Dim l As Long
Dim ws As Worksheet
Set ws = rng.Worksheet
i = rng.Column
r = rng.Row
If rng.HorizontalAlignment = xlHAlignCenterAcrossSelection Then
Do Until (ws.Cells(r, i).Value <> "" And rng.HorizontalAlignment = xlHAlignCenterAcrossSelection)
i = i - 1
Loop
End If
GetCenteredAcrossSelectionCellValue = ws.Cells(r, i).Value
End Function
However, I don't this this is foolproof, because it could be possible that someone applied Center Across Selection to a single cell (say A1 for example) with a value, and then applied Center Across Selection to 3 empty cells (B1:D1). When asked for the "value" for D1, the above code would return the value in A1.
Excel must know because it formats correctly, so is there an easy way to tell in VBA, similar to the way we can tell for Merged Cells?
Following on from the comment above...
Apply "center across selection" to A1:J1 then run tester with values in different cells in that range and compare the outputs.
Sub tester()
Dim c As Range, rng As Range
For Each c In Range("A1:J1")
Set rng = CenteredRange(c)
If Not rng Is Nothing Then
Debug.Print c.Address, rng.Address
Else
Debug.Print c.Address, "not centered"
End If
Next c
End Sub
'return the current "center across" range given a starting point
Function CenteredRange(c As Range) As Range
Dim cStart As Range, cEnd As Range, cNext As Range
Set c = c.Cells(1) 'make sure we're dealing with a single cell
If Not c.HorizontalAlignment = xlCenterAcrossSelection Then Exit Function
Set cStart = c.Parent.Range(c.Address)
Set cEnd = c.Parent.Range(c.Address)
'look for the beginning
Do While cStart.Column > 1 And cStart.HorizontalAlignment = xlCenterAcrossSelection
If Len(cStart.Value) > 0 Then Exit Do 'stop if find a value
Set cStart = cStart.Offset(0, -1)
Loop
'look for the end
Do While cEnd.Column < Columns.Count - 1 And cEnd.HorizontalAlignment = xlCenterAcrossSelection
Set cNext = cEnd.Offset(0, 1) 'checking the next cell...
If Len(cNext.Value) > 0 Or cNext.HorizontalAlignment <> xlCenterAcrossSelection Then Exit Do
Set cEnd = cEnd.Offset(0, 1)
Loop
Set CenteredRange = c.Parent.Range(cStart, cEnd)
End Function

Track how many times a cell changes

Given this spreadsheet
I am trying to track how many times a disk gets checked out. This the VBA I converted to check Rows instead of Columns. I copied this code from one of robinCTS posts and changed it. The problem I am seeing, when a value in cell B3 get changed, Cell B8 gets 1 added to it (Correct). If I change a value in cell D13, again cell D8 is updated (InCorrect, it should be cell D18). It is in the proper column, just the wrong row.
'============================================================================================
' Module : <The appropriate sheet module>
' Version : 1.0
' Part : 1 of 1
' References : N/A
' Source : https://stackoverflow.com/a/47405528/1961728
'============================================================================================
Option Explicit
Private Sub Worksheet_Change _
( _
ByVal Target As Range _
)
Const s_CheckRow As String = "3:3,13:13"
Const s_CountRow As String = "8:8,18,18"
If Intersect(Target, Range(s_CheckRow)) Is Nothing Then Exit Sub
Dim rngCell As Range
For Each rngCell In Intersect(Target, Range(s_CheckRow))
With Range(s_CountRow).Cells(rngCell.Column)
.Value2 = IIf(.Value2 <> vbNullString, .Value2 + 1, IIf(rngCell.Value2 <> vbNullString, 1, vbNullString))
End With
Next rngCell
End Sub
So what I am doing wrong?
Instead of Const s_CountRow As String = "8:8,18,18" (typo there?) I'd use a fixed offset from each changed cell:
Private Sub Worksheet_Change(ByVal Target As Range)
Const RNG_CHECK As String = "3:3,13:13"
Const ROW_OFFSET As Long = 5
Dim rng As Range, c As Range
Set rng = Application.Intersect(Target, Range(RNG_CHECK))
If rng Is Nothing Then Exit Sub
For Each c In rng.Cells
If Len(c.Value) > 0 Then
c.Offset(ROW_OFFSET).Value = c.Offset(ROW_OFFSET).Value + 1
End If
Next c
End Sub

How can I force user to enter negative number in Excel?

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...

Running a Program over a certain number of columns and rows

Problem with getting the program to run as I would like it to, I have managed to get the hole column to work but i need all 12 rows to work the rows stars at 20 so "T2" and skip a column next one is 22 so "V2"... all the way to "AP2".
The point in this program is to enter stock in the entry column and adding it with the current stock then the entry column becomes empty.
Private Sub worksheet_change(ByVal target As Range)
If target.Column = 20 And target.Value > 0 Then
Dim val As Double
val = target.Value
target.Value = 0
Cells(target.Row, target.Column - 1).Value = val + Cells(target.Row, target.Column - 1).Value
End If
End Sub
interesting approach. Try this...
The step by step processing of areas / columns of area / single cells will support copy+paste of several values in one step, copy copying from one cell into several other cells in one step.
The Application.EnableEvents statement prevents the event from firing itselfes.
Good luck! :-)
Private Sub worksheet_change(ByVal target As Range)
Dim rngArea As Range, rngColumn As Range, rngSingleCell As Range
Dim lngColumn As Long
Dim dblVal As Double
Application.EnableEvents = False
'loop though all changed areas
For Each rngArea In target
'loop though all changed columns of this area
For Each rngColumn In rngArea
'check if column number shall be processed, i.e. is 20 / 22 / 24 ... 42
lngColumn = rngColumn.Column
If ((lngColumn >= 20) And (lngColumn <= 42) And ((lngColumn Mod 2) = 0)) Then
'loop though all changed cells of this column of this area
For Each rngSingleCell In rngColumn
If rngSingleCell.Value > 0 Then
dblVal = rngSingleCell.Value
rngSingleCell.Value = 0
Cells(rngSingleCell.Row, rngSingleCell.Column - 1).Value = dblVal + Cells(rngSingleCell.Row, rngSingleCell.Column - 1).Value
End If
Next rngSingleCell
End If
Next rngColumn
Next rngArea
Application.EnableEvents = True
End Sub
Regards,
Kawi42

Counting conditional formatting cells by colorIndex

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.

Resources