Review of Application.EnableEvents = False/True lines in worksheet_change event

Ironman

Well-known Member
Joined
Jan 31, 2004
Messages
871
Office Version
  1. 365
Platform
  1. 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!
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
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

jasonb75

Well-known Member
Joined
Dec 30, 2008
Messages
14,572
Office Version
  1. 365
Platform
  1. Windows
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.
Looking over the code it appears that it is more a case of excess than insufficient, there are a couple of places where you have set it back to True in the middle of the code. Although there are times when it is necessary to do this in order to fire the event again it can potentially create an infinite loop.

I think that the best advice I can give here would be 'if it ain't broke, don't try and fix it'.
 

Forum statistics

Threads
1,148,390
Messages
5,746,431
Members
424,015
Latest member
kyites

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top