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
Related
I try to create a history database, sort of.
What I have done is if a value in Sheet1 C1 is updated, the previous value in cell A1 will be copied to Sheet2 C1. And if I update again the value in Sheet1 A1, the value will be copied again to Sheet2 C2, below the previous copy, and so on. Likewise, when a value in Sheet1 C2 is updated, it will be copied down below the previous copy of Sheet1 C1 value.
Now, after the value is updated, what I want to create is the title of which value being updated also being copied to Sheet2 B1, same as the value copy mechanism. Thank you.
The code is as follows:
Private Sub worksheet_change(ByVal target As Range)
If target.Column = 3 Then 'Determine which column is input cell
Dim col As Long
Dim intlastrow As Long
col = target.Column 'Determine which row/column is output cell
intlastrow = Sheet4.Cells(Rows.Count, col).End(xlUp).Row
If intlastrow = 1 Then 'Populate Row 1 or increment
If Sheet4.Cells(intlastrow, col).Value <> "" Then
intlastrow = intlastrow + 1
End If
Else
intlastrow = intlastrow + 1
End If
Sheet4.Cells(intlastrow, col) = target.Value
End If
End Sub
Solution with minimal changes:
You're pretty close with what you have, but here's my solution with as few changes as possible:
Private Sub worksheet_change(ByVal target As Range)
If target.Column = 3 Then 'Determine which column is input cell
Dim col As Long
Dim intlastrow As Long
Dim sh_History As Worksheet
Set sh_History = ThisWorkbook.Sheets("Sheet2") ' You seem to be using Sheet4, but I _
' don't have a Sheet4, so I set an object variable and use whatever name I give the _
' worksheet.
col = target.Column 'Determine which row/column is output cell
intlastrow = sh_History.Cells(Rows.Count, col).End(xlUp).Row
If intlastrow = 1 Then 'Populate Row 1 or increment
If sh_History.Cells(intlastrow, col).Value <> "" Then
intlastrow = intlastrow + 1
End If
Else
intlastrow = intlastrow + 1
End If
With sh_History.Cells(intlastrow, col) ' With statements are GREAT for shortening code!
.Value = target.Value ' This handles what you already had -- the Date column.
.Offset(0, -1).Value = target.Offset(0, -1).Value ' This handles your Title column.
End With
End If
End Sub
That works when I tested it.
Other suggestions
Comment 1
You have two lines that seem redundant:
If target.Column = 3 Then...
and
col = target.Column
It's not wrong, but appears odd to me because you've done your test with the If statement and have already determined that the target.Column equals 3 at that point. So why not just set col = 3? In fact, with this code operating all by itself, I would set that variable when first declaring the variable.
Comment 2
I don't quite follow what you are trying to do with empty cells, and specifically this section:
If intlastrow = 1 Then 'Populate Row 1 or increment
If sh_History.Cells(intlastrow, col).Value <> "" Then
intlastrow = intlastrow + 1
End If
Else
intlastrow = intlastrow + 1
End If
You don't want to put any values in Row 1 where you might be putting the header, "Date"; and you don't want to overwrite previous entries. I'm trying to think of a reason you can't delete that section above and just change this line:
intlastrow = sh_History.Cells(Rows.Count, col).End(xlUp).Row
to be this:
intlastrow = sh_History.Cells(Rows.Count, col).End(xlUp).Row + 1
The line above will ensure you never get Row 1 nor will you overwrite a cell with data. The only question is if you are trying to track the history of when you EMPTY a cell, because the minimal change code above will produce a temporary record of the Title when you delete a date -- but then it gets overwritten by the next change.
Which brings us to...
Comment 3
Guessing that you might want to track every change -- even deletions -- then you need to track the last row that was written to in history. You could do that by checking the last row of both the Title and Date columns and pick the maximum. My preferred way would be to write a timestamp of each change and just use that column and row for incrementing.
Suggested solution:
With the above thoughts incorporated in re-written sub, here's what I think you want in a more succinct fashion:
Private Sub worksheet_change(ByVal target As Range)
Dim col As Long
Dim intlastrow As Long
Dim sh_History As Worksheet
col = 3 ' Set the var to 3 here and if you need to change it, only one spot needs updating.
Set sh_History = ThisWorkbook.Sheets("Sheet2") ' object variable set
If target.Column = col Then ' Test target against desired column.
intlastrow = sh_History.Cells(Rows.Count, col + 1).End(xlUp).Row + 1
' Two changes in above line:
' 1). Incrementing the row by 1 right here so I can eliminate the previous IF statements.
' 2). I am adding a Timestamp column so you can track deletions, and to reference the Timestamp _
' I am going to column D, or ' col + 1 ' to ensure I find the last row.
With sh_History.Cells(intlastrow, col) ' With statements are GREAT for shortening code!
.Value = target.Value ' This handles what you already had -- the Date column.
.Offset(0, -1).Value = target.Offset(0, -1).Value ' This handles your Title column.
.Offset(0, 1).Value = Now() ' This is the TimeStamp column.
End With
End If
End Sub
It's good to also make sure your code can handle multi-cell changes:
Private Sub worksheet_change(ByVal target As Range)
Dim rng As Range, c As Range
Set rng = Application.Intersect(Me.Columns(3), target)
If rng Is Nothing Then Exit Sub
For Each c In rng.Cells
Sheet4.Cells(Rows.Count, c.Column).End(xlUp).Offset(1, 0).Resize(1, 2).Value = _
c.Offset(0, -1).Resize(1, 2).Value
Next c
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'm working on a large excel sheet(482 rows x 654 cols) with loads of formulas calculated, and I need to find the most efficient way to highlight the row/column corresponding to the selected row.
I tried 2 methods:
Conditional formatting with the formula:
=OR(CELL(“col”)=COLUMN(),CELL(“row”)=ROW())
and on
Worksheet_SelectionChange(ByVal target As Range)
target.Calculate
A macro that removes previous formatting and adds new formatting referencing the selected cell.
Both solutions trigger on selection change, and they slow down the use of the sheet by allot.
I have even tried to set a delay of 1 or 2 seconds, to only run the last action that the user made, canceling the event for action 1, if action 2 happens in that time-frame.
Does anyone have any advanced wisdom for me in this case, like a different trigger, or a hidden setting in Excel that would highlight current row/column more clearly than how excel does it by default?
Something like this?
Public lngRow As Long
Public lngCol As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.Interior.Color = XlColorIndex.xlColorIndexNone
If lngCol = 0 Or lngRow = 0 Then
lngCol = Target.Column
lngRow = Target.Row
FormatRow
FormatCol
Else
If lngCol <> Target.Column Then
lngCol = Target.Column
FormatCol
End If
If lngRow <> Target.Row Then
lngRow = Target.Row
FormatRow
End If
End If
End Sub
Function FormatRow()
Dim r As Excel.Range
Set r = Rows(lngRow)
r.Interior.Color = RGB(230, 230, 230)
End Function
Function FormatCol()
Dim r As Excel.Range
Set r = Columns(lngCol)
r.Interior.Color = RGB(230, 230, 230)
End Function
I have a large workbook and am trying to increase performance.
Is it possible/viable to store my formulas in some sort of list contained within the code rather than in the cells on the spreadsheet?
Variable SelectedRow = the currently selected row
For example:
ColumnBFormula = A(SelectedRow) + 1
ColumnCFormula = A(SelectedRow) + 2
If the user enters 4 in cell A3, then the macro writes formulas above ONLY in empty cells B3 and C3, then converts to values. The rest of the spreadsheet remains unchanged (should only have values everywhere).
Then the user enters a 6 in cell A4 and the spreadsheet writes the formulas to empty cells B4 and C4, calculates then converts to values.
Thanks
Try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lastrow As Long
'Refer to Sheet1
With ThisWorkbook.Worksheets("Sheet1")
'Check if Column A affected
If Not Intersect(Target, Range("A:A")) Is Nothing And IsNumeric(Target) Then
'Disable event to avoid event trigger
Application.EnableEvents = False
Target.Offset(0, 1).Value = Target + 1
Target.Offset(0, 2).Value = Target + 2
'Enable event
Application.EnableEvents = True
End If
End With
End Sub
Instructions:
Enable Events:
Given you know what you want the code to do, you could do this without entering formulas.
In the VBA editor, add this code into the "ThisWorkbook" object ...
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim objCell As Range
Application.EnableEvents = False
For Each objCell In Target.Cells
If objCell.Column = 1 Then
If objCell.Value = "" Then
objCell.Offset(0, 1) = ""
objCell.Offset(0, 2) = ""
Else
objCell.Offset(0, 1) = objCell.Value + 1
objCell.Offset(0, 2) = objCell.Value + 2
End If
End If
Next
Application.EnableEvents = True
End Sub
Hopefully that works for you.
FYI - You'll need to add the relevant error checking for values if not numeric etc, it will need to be improved.
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.