Automatically enter date & time as cell is updated/changed - excel

Background:
I want the macro to automatically record the time and date on the empty cell on right IF the "cell of interest" changes values through a formula.
e.g. IF cell("k3") changes values, THEN register DATE & TIME when it changed on cell ("L3");
IF cell("L3") IS NOT empty, THEN register the TIME & DATE in cell("M3"), and so forth until it finds an empty cell.
So far, I have not been able to prompt the macro whenever the "cell of interest" changes values.
PS: the latter is an IF formula that outputs 2 possible strings: "OK" and "ISSUE RISK WARNING"
I have tried the following code:
Private sub Register_timestamp(ByVal Target As Range)
'This sub registers the date and hour at which the cells in column K:K changed values.
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("K:K"))
xOffsetColumn = 1
If WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
xOffsetColumn = xOffsetColumn + 1
End If
Next
Application.EnableEvents = True
End If
End sub
Expected output:
If I were to manually change the cell that is subject to the "cell of interest"'s IF Function - and triggers it -, the date and time at which the "cell of interest" changed, e.g.: 14/05/2019 21:44:21

Here's how you'd implement my suggestions. Make sure this code is on the correct worksheet's code module.
Private Sub Worksheet_Calculate()
Dim rMonitored As Range
Dim MonitoredCell As Range
Dim vSelected As Variant
Dim aNewValues As Variant
Dim ixFormulaCell As Long
On Error Resume Next
Set rMonitored = Me.Columns("K").SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If rMonitored Is Nothing Then Exit Sub 'No formula cells in column K
Application.EnableEvents = False 'Disable events to prevent infinite calc loop
Set vSelected = Selection 'Remember current selection (it may not be a range)
'Prepare the array that will store the new values, the cells those values are in, and whether or not there was a change
ReDim aNewValues(1 To rMonitored.Cells.Count, 1 To 3)
'Column1 = new value
'Column2 = cell address
'Column3 = did value change?
'Get the new value for each formula in column K
ixFormulaCell = 0
For Each MonitoredCell In rMonitored.Cells 'The formula cells may not be in a contiguous range
ixFormulaCell = ixFormulaCell + 1
aNewValues(ixFormulaCell, 1) = MonitoredCell.Value 'Store the new value
Set aNewValues(ixFormulaCell, 2) = MonitoredCell 'Store the cell address
Next MonitoredCell
Application.Undo 'This will undo the most recent change, which allows us to compare the new vs old to check for formula updates
ixFormulaCell = 0
For Each MonitoredCell In rMonitored.Cells
ixFormulaCell = ixFormulaCell + 1
'Check if the formula result is different
If MonitoredCell.Value <> aNewValues(ixFormulaCell, 1) Then
'Formula result found to be different, record that
'We can't put the timestamp in now because we still have to redo the most recent change
aNewValues(ixFormulaCell, 3) = True
End If
Next MonitoredCell
Application.Undo 'Redo the most recent change to put worksheet back in the new state
'Now that we've completed our comparison and have re-done the most recent change, check what did change and put in a timestamp in the next empty cell in same row
For ixFormulaCell = LBound(aNewValues, 1) To UBound(aNewValues, 1)
'Check for formula result change
If aNewValues(ixFormulaCell, 3) Then
'Formula result change found, get next empty cell in same row
With Me.Cells(aNewValues(ixFormulaCell, 2).Row, Me.Columns.Count).End(xlToLeft).Offset(, 1)
'Next empty cell found, put in the current datetime stamp and format it
.Value = Now
.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
End With
End If
Next ixFormulaCell
vSelected.Select 'Re-select the remembered selection so that this operation is invisible to users
Application.EnableEvents = True 'Re-enable events so that the next calculation can be monitored for formula changes in cells of interest
End Sub

Related

Copy values as they're entered into a column & paste to another worksheet - where am I going wrong?

vAs the title suggests, I'm trying to copy and paste values to keep as a log as these values will be deleted shortly after they've been entered.
Long story short, a user will scan a barcode and a unique string of characters that correspond to the scanned barcode will be automatically entered into whichever cell is selected (usually A2). These strings are parent barcodes, so immediately after one has been scanned into A2 the user will start scanning their related children barcodes into B2, B3 and so on depending on how many children there are (always a completely random number).
Here's what I have so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim intRow As Integer
Dim intCount As Integer
Set ws = Worksheets("log")
intRow = ws.Range("A1").CurrentRegion.Rows.Count + 1
'Check if WandID exist in log.
If Target.Address = "$A$2" Then
intCount = Application.WorksheetFunction.CountIf(ws.Range("D:D"), Target.Value)
If intCount <> 0 Then
Target.Interior.Color = RGB(255, 0, 0)
MsgBox "this wandID has already been used, please try a different barcode"
Range("A2").ClearContents
End
Else
Target.Interior.Color = xlNone
ws.Cells(intRow, "D") = Target.Parent.Range("A2")
ws.Cells(intRow, "E") = Target
End If
End If
End Sub
On the destination worksheet (named 'log') I've set up a simple table to organise the copied / scanned data and added some dummy data as a first entry - seeing as this workbook will be used regularly I wanted this process to keep adding scanned codes beneath the previous (dummy parent code in D2, dummy child codes in E2:E9), so ideally when I enter a new parent code into A2 of the source sheet, it should be copied to D10 on the destination sheet, and any corresponding child codes added to B2 etc. of the source sheet should be copied to E10 etc. of the destination sheet. Instead what's happening is the parent code will be added to D10:E10.
I have a feeling the line
"ws.Cells(intRow, "E") = Target"
is the problem, but not sure of what to change it to.
Any help or advice would be hugely appreciated!
I believe the code below will help you achieve your objective, it checks for the Next Free Row on Column D and that's where the Parent ID will be entered, similarly it will check the Child IDs in Column B and find the Next available row on Column E to paste the list into, the main changes are the use of Application.EnableEvents and the copy of data from Column B to Column E:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet: Set ws = Worksheets("log")
Dim NextRow As Long, ChildRow As Long, ChildNextRow As Long
NextRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Offset(1, 0).Row
'get the Next Free row in Column D
ChildRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'get the Last Row with data on Column B
ChildNextRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Offset(1, 0).Row
'get the Next Free Row on Column E
'Check if WandID exist in log (Column D).
If Target.Address = "$A$2" Then
Application.EnableEvents = False
'Turn Events off, so it doesn't fire the Change Event while we write to it
intCount = Application.WorksheetFunction.CountIf(ws.Range("D:D"), Target.Value)
'check if Parent ID has been used previously by check Column D
If intCount <> 0 Then
Target.Interior.Color = RGB(255, 0, 0)
MsgBox "This wandID has already been used, please try a different barcode", vbInformation, "Duplicate Entry"
ws.Range("A2").ClearContents
Else
Target.Interior.Color = xlNone
ws.Cells(NextRow, "D") = ws.Range("A2")
ws.Range("B2:B" & ChildRow).Copy Destination:=ws.Range("E" & ChildNextRow)
End If
Application.EnableEvents = True
End If
End Sub

My two macros "clash", i.e. they cannot operate simultaneously

Background
I have 2 macros in one of my worksheets that i) get the Previous Close price from Bloomberg's website straight into the worksheet [trigered by a button] (Cells H3:downwards) and ii) the other registers a timestamp if this new value causes a change in a formula located in cells K3:downwards. Then, if there is any change, the time in which it happened will be registered in the columns to the immediate right of column H.
My problem lies in that when I press the button to launch Macro i), the debugger pops "Run time error 1004. Method 'undo' of Object'_application' failed " causing Macro ii) to stop working (i.e. to stop registering the time in which there was a change in value in the column of interest). The line of code highlighted by the debugger is "Application.undo"
To be honest, I am a bit lost on the process.
This is the code
Disclaimer: Most of the comments are there to educate myself on how the code actually works. Many thanks to everyone who contributed to both Subs.
Private Sub Worksheet_Calculate()
Dim rMonitored As Range
Dim MonitoredCell As Range
Dim vSelected As Variant
Dim aNewValues As Variant
Dim ixFormulaCell As Long
On Error Resume Next
Set rMonitored = Me.Columns("K").SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If rMonitored Is Nothing Then Exit Sub 'No formula cells in column K
Application.EnableEvents = False 'Disable events to prevent infinite calc loop
Set vSelected = Selection 'Remember current selection (it may not be a range)
'Prepare the array that will store the new values, the cells those values are in, and whether or not there was a change
ReDim aNewValues(1 To rMonitored.Cells.Count, 1 To 3)
'Column1 = new value
'Column2 = cell address
'Column3 = did value change?
'Get the new value for each formula in column K
ixFormulaCell = 0
For Each MonitoredCell In rMonitored.Cells 'The formula cells may not be in a contiguous range
ixFormulaCell = ixFormulaCell + 1
aNewValues(ixFormulaCell, 1) = MonitoredCell.Value 'Store the new value
Set aNewValues(ixFormulaCell, 2) = MonitoredCell 'Store the cell address
Next MonitoredCell
Application.Undo 'This will undo the most recent change, which allows us to compare the new vs old to check for formula updates
ixFormulaCell = 0
For Each MonitoredCell In rMonitored.Cells
ixFormulaCell = ixFormulaCell + 1
'Check if the formula result is different
If MonitoredCell.Value <> aNewValues(ixFormulaCell, 1) Then
'Formula result found to be different, record that
'We can't put the timestamp in now because we still have to redo the most recent change
aNewValues(ixFormulaCell, 3) = True
End If
Next MonitoredCell
Application.Undo 'Redo the most recent change to put worksheet back in the new state
'--> THE LINE OF CODE ABOVE IS WHAT THE DEBUGGER POINTS TO
'Now that we've completed our comparison and have re-done the most recent change, check what did change and put in a timestamp in the next empty cell in same row
For ixFormulaCell = LBound(aNewValues, 1) To UBound(aNewValues, 1)
'Check for formula result change
If aNewValues(ixFormulaCell, 3) Then
'Formula result change found, get next empty cell in same row
With Me.Cells(aNewValues(ixFormulaCell, 2).Row, Me.Columns.Count).End(xlToLeft).Offset(, 1)
'Next empty cell found, put in the current datetime stamp and format it
.Value = Now
.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
End With
End If
Next ixFormulaCell
vSelected.Select 'Re-select the remembered selection so that this operation is invisible to users
Application.EnableEvents = True 'Re-enable events so that the next calculation can be monitored for formula changes in cells of interest
End Sub
Public Sub test()
Dim re As Object, pairs(), ws As Worksheet, i As Long, s As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set re = CreateObject("VBScript.RegExp")
With ws
pairs = Application.Transpose(.Range("G3:G" & .Cells(.Rows.Count, "G").End(xlUp).Row).Value) ' assumes pairs start in row 3
End With
Dim results()
ReDim results(1 To UBound(pairs))
With CreateObject("MSXML2.XMLHTTP")
For i = LBound(pairs) To UBound(pairs)
.Open "GET", "https://www.bloomberg.com/quote/" & pairs(i) & ":CUR", False
.send
s = .responseText
results(i) = GetCloseValue(re, s, "previousClosingPriceOneTradingDayAgo%22%3A(.*?)%2")
Next
End With
ws.Cells(3, "I").Resize(UBound(results), 1) = Application.Transpose(results)
End Sub
Public Function GetCloseValue(ByVal re As Object, inputString As String, ByVal pattern As String) As String 'https://regex101.com/r/OAyq30/1
With re
.Global = True
.MultiLine = True
.IgnoreCase = False
.pattern = pattern
If .test(inputString) Then
GetCloseValue = .Execute(inputString)(0).SubMatches(0)
Else
GetCloseValue = "Not found"
End If
End With
End Function
Expected output
I would like both Macros to work simultaneously.

Calculate only selected row

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.

Put timestamp when a checkbox is ticked or unticked

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

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