Ironman
Well-known Member
- Joined
- Jan 31, 2004
- Messages
- 1,069
- Office Version
- 365
- Platform
- Windows
Hi
Over a period of time I've been very kindly given code for different worksheet_change events from some really helpful gentlemen on this board. Because each of the solutions was given to me in isolation i.e. without the knowledge of the other code in the worksheet_change event I don't know if there are sufficient Application.EnableEvents = False/True lines in the full code below.
For my peace of mind I'd be really grateful if you could review the below code to identify any parts that should have Application.EnableEvents = False/True lines inserting please, so I can avoid an issue arising at a future date.
Many thanks!
Over a period of time I've been very kindly given code for different worksheet_change events from some really helpful gentlemen on this board. Because each of the solutions was given to me in isolation i.e. without the knowledge of the other code in the worksheet_change event I don't know if there are sufficient Application.EnableEvents = False/True lines in the full code below.
For my peace of mind I'd be really grateful if you could review the below code to identify any parts that should have Application.EnableEvents = False/True lines inserting please, so I can avoid an issue arising at a future date.
Many thanks!
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
' Courtesy of Peter S_Ss 09.08.2021 https://www.mrexcel.com/board/threads/code-needed-instead-of-existing-formula-to-match-fill-colour-of-cell.1178650/
CALC = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim r As Long, Clr As Long
Dim Txt As String
If Not Intersect(Target, Columns("B")) Is Nothing Then
With Range("A12", Range("B" & Rows.Count).End(xlUp))
r = .Rows.Count
Do Until UCase(.Cells(r, 2).Value) <> "REST" And Not IsEmpty(.Cells(r, 2).Value)
r = r - 1
Loop
Select Case Date - .Cells(r, 1).Value
Case 0: Txt = "Today"
Case 1: Txt = "Yesterday"
Case Else: Txt = Format(.Cells(r, 1).Value, "d mmmm")
End Select
Clr = .Cells(r, 1).Interior.Color
End With
Application.EnableEvents = False
With Range("A8")
.Value = "Last Exercise " & Txt
.Interior.Color = Clr
End With
End If
'03.09.2021 The following courtesy of Eric W creates a msgbox when the max YTD mileage and run duration have been exceeded https://www.mrexcel.com/board/threads/message-box-when-cell-value-becomes-largest-in-range.1180863/
'The code was amended to autoupdate every Jan 1, courtesy of Peter_SSs https://www.mrexcel.com/board/threads/change-range-in-worksheet_change-event-code-every-jan-1.1180867/#post-5747473
Dim MyData As Variant, OldMax As Double
Dim ThisYearRow1 As Long, ThisYearDays As Long
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub 'Exit if multiple cells changed (this line added 08.11.2021 by Peter S_Ss and avoids VBA error 13 when more than 1 cell is amended at once, which includes formatting)
Const BaseRow As Long = 8413 'Row 8413 i.e. 1 Jan 2021
ThisYearRow1 = DateSerial(Year(Date), 1, 1) - DateSerial(2021, 1, 1) + BaseRow
ThisYearDays = DateSerial(Year(Date) + 1, 1, 1) - DateSerial(Year(Date), 1, 1)
Set rng = Range("C" & ThisYearRow1).Resize(ThisYearDays)
If Not Intersect(Target, rng) Is Nothing Then
MyData = rng.Value
MyData(Target.Row - ThisYearRow1 + 1, 1) = ""
OldMax = WorksheetFunction.Max(MyData)
If Target.Value > OldMax Then MsgBox "Congratulations - you've now run the furthest number of miles this year!", vbInformation, "Furthest Run So Far This Year"
End If
Set rng = rng.Offset(, 1) 'For Column D
If Not Intersect(Target, rng) Is Nothing Then
MyData = rng.Value
MyData(Target.Row - ThisYearRow1 + 1, 1) = ""
OldMax = WorksheetFunction.Max(MyData)
If Target.Value > OldMax Then MsgBox "Congratulations - you've just done the longest duration run this year!", vbInformation, "Longest Run Duration YTD"
End If
'01.10.2021 The following courtesy of NoSparks https://www.mrexcel.com/board/threads/integrate-module-into-an-existing-worksheet_change-event.1183367/#post-5763502
'Automates data input for the next Indoor Bike entry - populates Col I with "Indoor Bike Session, 60 mins.", then jumps from Col F to Col H and after entering session rating, jumps to Col I
'Tested to see if would still convert to link if text shortened to "Indoor Bike Session" (in case future session formats change) and it does
Dim NextRow As Long
Application.EnableEvents = False 'added 09.11.2021
lr = Range("A" & Rows.Count).End(xlUp).Row
If Target.Column = 2 And Target.Value = "OTHER (IB)" Then
Range("D" & Target.Row).Validation.Delete 'clears irrelevant Iron Man run validation input info
Range("E" & Target.Row).ClearContents 'clears irrelevant pace formula
Range("A" & Target.Row).Resize(, 6).Interior.Color = RGB(197, 217, 241) 'Col A and next 5 columns
Range("I" & Target.Row).Resize(, 2).Interior.Color = RGB(197, 217, 241) 'Col I and next column
Range("I" & Target.Row).Value = "INDOOR BIKE SESSION, 60 MINS."
Range("F" & Target.Row).Select 'move to this cell to start inputting data
MsgBox "Enter Average Heart Rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If
' jump from F to H on the same row
If Target.Address(0, 0) = Range("F" & lr).Address(0, 0) Then
Range("H" & lr).Select
MsgBox "Enter Session Rating", vbInformation, "Indoor Bike Session Data"
End If
' monitor column H and look for what's in I
If Target.Column = 8 And Target.Row = Range("A" & Rows.Count).End(xlUp).Row Then
Range("H" & Target.Row).Validation.Delete 'added 31.10.2021 - clears validation input info, no longer needed
Lr1 = Target.Row
If UCase(Trim(Left(Sheets("Training Log").Range("I" & Lr1).Value, 19))) = "INDOOR BIKE SESSION" Then
Lr2 = Sheets("Indoor Bike").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Indoor Bike").Range("F" & Lr2 & ":G" & Lr2).Value = Sheets("Training Log").Range("F" & Lr1 & ":G" & Lr1).Value 'ave heart rate
Sheets("Indoor Bike").Range("I" & Lr2).Value = Sheets("Training Log").Range("H" & Lr1).Value 'session rating
Sheets("Indoor Bike").Range("A" & Lr2).Value = Sheets("Training Log").Range("A" & Lr1).Value 'date
Sheets("Indoor Bike").Range("B" & Lr2).Value = "1:00:00" 'session length
Sheets("Indoor Bike").Range("E" & Lr2).Value = "8" 'resistence level
Application.EnableEvents = True 'added 09.11.2021
End If
End If
'24.09.2021 The line below creates CTRL (^) + \ keyboard shortcut to Indoor Bike Links macro (in Modules list - converts "Indoor bike session..." text to a link)
Application.OnKey "^\", "FindValues"
'17.10.2021 The following courtesy of jasonb75 https://www.mrexcel.com/board/threads/small-tweak-needed-so-code-runs-in-correct-column.1184894/#post-5772462
'is a reminder/link to input mileage for non-regular (i.e. input manually, not with the form) running routes in Daily Tracking sheet
Dim LastRow As Long
Application.EnableEvents = False 'added 09.11.2021
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
If Target.Address = Cells(LastRow, "B").Address Then
Select Case Target.Value
Case "OTHER (IB)", "OTHER (OB)", "OTHER (W)", "OTHER (T)", "REST", ""
' do nothing
Case Else
Range("D" & Target.Row).Validation.Delete 'clears irrelevant form-related Iron Man run validation input info
MsgBox "Input distance in Daily Tracking sheet first" & vbNewLine & _
"so Training Log Cells F2 & F3 update!", vbInformation, "Non-Regular Route"
Sheets("Daily Tracking").Select 'Sheet Activation set to select first blank cell in current year (Dante Amor 18.10.2021)
End Select
End If
' 10.10.2021 Look for what's in Col D and if value is greater than or equal to 2 hours, then copy to first empty row of Iron Man Log and fill Training Log cell appropriate colour (cell fill added 09.11.2021 - only works with irregular routes, not form inputs)
If Target.Column = 4 And Target.Row = Range("A" & Rows.Count).End(xlUp).Row Then
Lr1 = Target.Row
If Sheets("Training Log").Range("D" & Lr1).Value >= 0.0833 Then
Lr2 = Sheets("Iron Man Log").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Iron Man Log").Range("A" & Lr2).Value = Sheets("Training Log").Range("A" & Lr1).Value 'date
Sheets("Iron Man Log").Range("B" & Lr2).Value = Sheets("Training Log").Range("C" & Lr1).Value 'distance
Sheets("Iron Man Log").Range("C" & Lr2).Value = Sheets("Training Log").Range("D" & Lr1).Value 'time
' 09.11.2021
'Iron Man Bronze (2-3hrs)
If Sheets("Training Log").Range("D" & Lr1).Value >= 0.0833 And Sheets("Training Log").Range("D" & Lr1).Value < 0.1249 Then
Sheets("Training Log").Range("D" & Lr1).Resize(, 1).Interior.Color = RGB(255, 204, 153)
End If
'Iron Man Silver (3-3.5hrs)
If Sheets("Training Log").Range("D" & Lr1).Value >= 0.125 And Sheets("Training Log").Range("D" & Lr1).Value < 0.1458 Then
Sheets("Training Log").Range("D" & Lr1).Resize(, 1).Interior.Color = RGB(191, 191, 191)
End If
'Iron Man Gold (3.5hrs - 4hrs)
If Sheets("Training Log").Range("D" & Lr1).Value >= 0.1459 And Sheets("Training Log").Range("D" & Lr1).Value < 0.1665 Then
Sheets("Training Log").Range("D" & Lr1).Resize(, 1).Interior.Color = RGB(255, 204, 0)
End If
'Iron Man Platinum (4hrs+)
If Sheets("Training Log").Range("D" & Lr1).Value >= 0.1667 Then
Sheets("Training Log").Range("D" & Lr1).Resize(, 1).Interior.Color = RGB(242, 242, 242)
End If
End If
End If
'10.10.2021 The following courtesy of JoeMo triggers a message box when a time is entered in Col D and active cell then moves to Col F to enter heart rate
'https://www.mrexcel.com/board/threads/worksheet_change-event-msgbox-select-another-cell-when-column-in-last-row-filled.1184249/
Dim LastRw As Long
Application.EnableEvents = False
LastRw = Cells(Rows.Count, "D").End(xlUp).Row
If Target.Address = Cells(LastRw, "D").Address Then
If InStr(CStr(Cells(LastRw, "I").Value), "Day " & Range("F6") & ". ") Then
Else
Cells(LastRw, "I").Value = "Day " & Range("F6") & ". " & Cells(LastRw, "I").Value
End If
MsgBox "Enter Average Heart Rate", vbInformation, "Running Data"
Cells(LastRw, "F").Select
End If
'Adapted from 01.10.2021 NoSparks' code to fill row grey for REST entries
If Target.Column = 2 And Target.Value = "REST" Then
Range("A" & Target.Row).EntireRow.Validation.Delete 'deletes all validation in row (not needed in REST row)
Range("E" & Target.Row).ClearContents 'clears irrelevant pace formula
Range("A" & Target.Row).Resize(, 10).Interior.Color = RGB(217, 217, 217)
Range("A23358").End(xlUp).Offset(1, 0).Select
End If
'07.11.2021 Adapted from 01.10.2021 NoSparks' code to fill row light green for Walking entries
If Target.Column = 2 And Target.Value = "OTHER (W)" Then
Range("A" & Target.Row).Resize(, 6).Interior.Color = RGB(235, 241, 222) 'Col A and next 5 columns
Range("I" & Target.Row).Resize(, 2).Interior.Color = RGB(235, 241, 222) 'Col I and next column
Range("D" & Target.Row).Validation.Delete 'clears irrelevant Iron Man run validation input info
Range("E" & Target.Row).ClearContents 'clears irrelevant pace formula
Range("F" & Target.Row).Select 'move to this cell to input HR
End If
'07.11.2021 Adapted from 01.10.2021 NoSparks' code to fill row light yellow for Outdoor Bike entries
If Target.Column = 2 And Target.Value = "OTHER (OB)" Then
Range("A" & Target.Row).Resize(, 6).Interior.Color = RGB(255, 255, 204) 'Col A and next 5 columns
Range("I" & Target.Row).Resize(, 2).Interior.Color = RGB(255, 255, 204) 'Col I and next column
Range("D" & Target.Row).Validation.Delete 'clears irrelevant Iron Man run validation input info
Range("E" & Target.Row).ClearContents 'clears irrelevant pace formula
Range("F" & Target.Row).Select 'move to this cell to input HR
End If
'Adapted from 10.10.2021 JoeMo's code to replace validation dropdown for running entries (triggered by Day in Col I) with input msg
If Target.Column = 9 And Left(Target.Value, 3) = "Day" Then 'Alternative: InStr(1, "Day", "Day") = 1 Then
Application.EnableEvents = False
With Range("C" & Rows.Count).End(xlUp).Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
.InputMessage = "Double click for lifetime mileage total up to this date"
.ShowInput = True
End With
End If
'The following code separates different tasks in order to isolate sections that are not working properly.
'Messages are contained here:
Call ImportantMessages
Application.Calculation = CALC
Application.Calculate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub ImportantMessages()
'Bronze standard (183 days exercised YTD)
Dim HelperCell As Range
Dim wsHelperSheet As Worksheet
Set wsHelperSheet = Sheets("Training Log") ' <--- Set this to desired Helper sheet
Set HelperCell = wsHelperSheet.Range("K8") ' <--- Set this to desired cell address to store the flag
'
CurrentYear = Year(Date) ' Get current year
'
If HelperCell <= CurrentYear And Range("VBA_YTD_DAYS") = 183 Then ' If flag < or = to CurrentYear and
' ' ThisYr total> LastYr total then ...
HelperCell = CurrentYear + 1 ' Increment flag so msgbox will not be executed until the next year
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the bronze standard: " & vbNewLine _
& "You've exercised 3-4 times a week on average this year", vbInformation, "Year to Date Exercise" ' Display message to user
End If
'Silver standard (256 days exercised YTD)
Dim HelperCell1 As Range
Dim wsHelperSheet1 As Worksheet
Set wsHelperSheet1 = Sheets("Training Log") ' <--- Set this to desired Helper sheet
Set HelperCell1 = wsHelperSheet.Range("K9") ' <--- Set this to desired cell address to store the flag
'
CurrentYear = Year(Date) ' Get current year
'
If HelperCell1 <= CurrentYear And Range("VBA_YTD_DAYS") = 256 Then ' If flag < or = to CurrentYear and
' ' ThisYr total> LastYr total then ...
HelperCell1 = CurrentYear + 1 ' Increment flag so msgbox will not be executed until the next year
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the silver standard: " & vbNewLine _
& "You've exercised 5 times a week on average this year", vbInformation, "Year to Date Exercise" ' Display message to user
End If
'Gold standard (312 days exercised YTD)
Dim HelperCell2 As Range
Dim wsHelperSheet2 As Worksheet
Set wsHelperSheet2 = Sheets("Training Log") ' <--- Set this to desired Helper sheet
Set HelperCell2 = wsHelperSheet.Range("K10") ' <--- Set this to desired cell address to store the flag
'
CurrentYear = Year(Date) ' Get current year
'
If HelperCell2 <= CurrentYear And Range("VBA_YTD_DAYS") = 312 Then ' If flag < or = to CurrentYear and
' ' ThisYr total> LastYr total then ...
HelperCell2 = CurrentYear + 1 ' Increment flag so msgbox will not be executed until the next year
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the gold standard: " & vbNewLine _
& "You've exercised 6 times a week on average this year", vbInformation, "Year to Date Exercise" ' Display message to user
End If
'500 miles run this year
Dim HelperCell3 As Range
Dim wsHelperSheet3 As Worksheet
Set wsHelperSheet3 = Sheets("Training Log") ' <--- Set this to desired Helper sheet
Set HelperCell3 = wsHelperSheet.Range("K11") ' <--- Set this to desired cell address to store the flag
'
CurrentYear = Year(Date) ' Get current year
'
If HelperCell3 <= CurrentYear And Range("VBA_YTD_MILES") > 499 And Range("VBA_YTD_MILES") < 504 Then ' If flag < or = to CurrentYear and
' ' ThisYr total> LastYr total then ...
HelperCell3 = CurrentYear + 1 ' Increment flag so msgbox will not be executed until the next year
MsgBox "Congratulations! You've just run your 500th mile this year", vbInformation, "Year to Date Mileage" ' Display message to user
End If
'1,000 miles run this year
Dim HelperCell4 As Range
Dim wsHelperSheet4 As Worksheet
Set wsHelperSheet4 = Sheets("Training Log") ' <--- Set this to desired Helper sheet
Set HelperCell4 = wsHelperSheet.Range("K12") ' <--- Set this to desired cell address to store the flag
'
CurrentYear = Year(Date) ' Get current year
'
If HelperCell4 <= CurrentYear And Range("VBA_YTD_MILES") > 999 And Range("VBA_YTD_MILES") < 1010 Then ' If flag < or = to CurrentYear and
' ' ThisYr total> LastYr total then ...
HelperCell4 = CurrentYear + 1 ' Increment flag so msgbox will not be executed until the next year
MsgBox "Congratulations! You've just run your 1,000th mile this year", vbInformation, "Year to Date Mileage" ' Display message to user
End If
'28.10.2021 The following is courtesy of hrayani and Michael M and triggers a message box when the next 1,000 miles have been run
'https://www.mrexcel.com/board/threads/message-box-when-value-is-within-100-of-the-next-1000.1183785/
Dim a As Integer
a = Range("F5").Value Mod 1000
If a > 0 And a <= 10 And Range("H1") = "" Then
MsgBox "Congratulations! You have now run over " & Format(Range("F5").Value + 1000 - a, "#,##0") & " miles", vbInformation, "1,000 More Miles Run"
Range("H1") = "1" '12.11.2021 helper cell added to suppress msgboxes every time sheet changes (cleared on ThisWorkbook_Close)
End If
'27.10.2021 The following is courtesy of hrayani and Michael M and triggers a message box when the next 1,000 runs has been reached
'https://www.mrexcel.com/board/threads/message-box-when-value-is-within-100-of-the-next-1000.1183785/
Dim b As Integer
b = Range("F6").Value Mod 1000
If b = 0 And Range("H2") = "" Then
MsgBox "Congratulations! You have now been out running " & Format(Range("F6").Value + 1000 - b, "#,##0") & " times", vbInformation, "Days Run Since April 16, 1981"
Range("H2") = "1" '12.11.2021 helper cell added to suppress msgboxes every time sheet changes (cleared on ThisWorkbook_Close)
End If
'28.10.2021 The following is courtesy of hrayani and Michael M and triggers a message box when the next 1,000 miles have been run from home address
'https://www.mrexcel.com/board/threads/message-box-when-value-is-within-100-of-the-next-1000.1183785/
Dim c As Integer
c = Range("MilesFromHomeAddress").Value Mod 1000
If c > 0 And c <= 10 And Range("H3") = "" Then
MsgBox "Congratulations! You have now run over " & Format(Range("MilesFromHomeAddress").Value - c, "#,##0") & " miles from Hallas Hall Farm", vbInformation, "1,000 More Miles Run"
Range("H3") = "1" '12.11.2021 helper cell added to suppress msgboxes every time sheet changes (cleared on ThisWorkbook_Close)
End If
'Time to replace running shoes
'09.11.2021 the below is courtesy of NoSparks https://www.mrexcel.com/board/threads/message-box-every-650-units-from-todays-value.1186984/#post-5784473
Dim d As Long
d = [F5] Mod 650 'lifetime mileage, increments of 650 (expected life of running shoes)
If d > 171 And d < 186 And Range("H4") = "" Then '186 = No. miles you have left in current pair of shoes (08.11.2021 lifetime mileage was 27,946 and shoes had another 186 miles left before wearing out at 650 miles). 186-171 = 15 miles, or a week's notice when weekly total is 15 miles.
MsgBox "You've almost reached 650 miles in your running shoes" & vbNewLine & vbNewLine _
& "Nearly time to buy a new pair!", vbInformation, "Running Shoes Nearly Worn Out"
Range("H4") = "1"
ElseIf d = 186 And Range("H4") = "" Then
MsgBox "You've now reached 650 miles in your running shoes" & vbNewLine & vbNewLine _
& "Time to buy a new pair!", vbInformation, "Running Shoes Worn Out"
Range("H4") = "1"
ElseIf d > 186 And d < 216 And Range("H4") = "" Then '30 mile (2 week) nags to make you go out and buy them!
MsgBox "You've exceeded 650 miles in your running shoes" & vbNewLine & vbNewLine _
& "You need to buy a new pair!", vbInformation, "Running Shoes Worn Out"
Range("H4") = "1"
End If
Application.EnableEvents = True
End Sub
