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.
Related
Can someone help me with retrieving the corresponding row and column when a range is selected via Refedit? I put the pictures below how it looks like.
What I want to do is when I select a range (for example E12:E16) via the "Refedit1" in my userform, it should return the start and end time for the corresponding row (11AM - 3PM +1) and the corresponding date in column (wednesday 26/02/2020)
Next step would be to insert these values immediately inside the 3 DTPickers but this I can do once I have the return values, I think.
I tried all different codes that I found and they always give me either the value that is in the cell ("" in this example), a text string like "sheet1$E$12 or when I use Active.Cell it returns the cell that was active before I selected my range through RefEdit.
Hopefully someone can point me in the right direction, I would help me a lot! Sorry that I couldn`t upload the original excel file but there was to many confidential info in it...
sheet layout
Userform layout
Private Sub CommandButton2_Click()
Dim rRange As Range
Dim strAddr As String
Dim bIsRange As Boolean
'Get the address, or reference, from the RefEdit control.
strAddr = RefEdit1.Value
'Use IsObject to find out if the string is a valid address.
On Error Resume Next
bIsRange = IsObject(Range(strAddr))
On Error GoTo 0
If bIsRange = False Then 'Not Valid
MsgBox "The range is not valid"
RefEdit1.Value = vbNullString
RefEdit1.SetFocus
Exit Sub
End If
'Set the rRange Range variable to the range nominated by the
'RefEdit control. If the Sheet name is also include (eg Sheet2!A1:A10)
'It will act on that range, even if the sheet is not active at the time.
Set rRange = Range(strAddr)
' gives the cell reference as a string
MsgBox strAddr
With rRange
'.Interior.ColorIndex = 16
.Font.Bold = True
'.BorderAround LineStyle:=xlContinuous, Weight:=xlThick
End With
If strAddr = "" Then
'do nothing
Else
Range(strAddr).Value = UserForm1.ComboBox2.Value
End If
End Sub
You can read the date and times like this:
With rRange
'.Interior.ColorIndex = 16
.Font.Bold = True
'.BorderAround LineStyle:=xlContinuous, Weight:=xlThick
startTime = .cells(1).EntireRow.cells(2).Value
endTime = .cells(.cells.count).EntireRow.cells(2).Value
theDate = .cells(1).EntireColumn.cells(5).Value
End With
Manual - Select range, execute Sub
How it works - Sub saves all non-blank cells to finalArray that is ultimately displayed in the selected range
What's the problem - if range contains cells with hyperlinks created via insert-hyperlink, the hyperlinks disappear.
Sub RemoveBlanks()
'i,j - counters, k - offset
Dim finalArray() As Variant
ReDim finalArray(Selection.Rows.Count, 1)
k = 1
For i = 1 To Selection.Rows.Count
If Selection(i, 1) <> "" Then
finalArray(k, 1) = Selection(i, 1)
k = k + 1
End If
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
Selection.Clear
For i = 1 To k
Selection(i, 1).Value = finalArray(i, 1)
Next i
End Sub
This Code will loops through each cell in the selected range, checks if the cell has a hyperlink then temporarily grab and store the address that it’s pointing to re-apply the hyperlink
Option Explicit
Sub fixHyperlinks()
Dim rng As Range
Dim address As String
Application.ScreenUpdating = False
For Each rng In Selection
If rng.Hyperlinks.Count > 0 Then
address = rng.Hyperlinks(rng.Hyperlinks.Count).address
rng.Hyperlinks.Add Anchor:=rng, _
address:=address
End If
Next
Application.ScreenUpdating = True
End Sub
After you run this code, you should be able to set in your array the range without losing your links.
Conclusion : Run this code before you run your macro.
So I have found a way around the issue after lurking through internet and trying to save links in another array (fails). It works only if the value in the cell is the same as name of a sheet, yet it solves my issue so far.
Sub CreateLinks()
'i - counter, the title as i=1 is omitted. Code uses value stored in cell to
'transform it into a link.
Dim i As Integer
For i = 2 To Selection.Rows.Count
If Selection(i) <> "" Then
ActiveSheet.Hyperlinks.Add anchor:=Selection(i), _
address:="#'" & CStr(Selection(i)) & "'!A1", _
TextToDisplay:=CStr(Selection(i))
End If
Next i
End Sub
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
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.