'Private Sub Worksheet_Activate()
'The following line ensures worksheet view is always set to the last entry.
'If you want the active cell to be the first blank cell, uncomment this line and change last part to .Offset(1, 0).Select
'NB - if you do this, you won't be able to make use of the Analysis & Race Log hyperlinks back to Training Log!
'Range("A23358").End(xlUp).Offset(0, 0).Select
'08.09.2021 Paul - this code is probably related to the RouteInfo form but I can't find any reference to it in that code.
Private Function AllFilled(target As Range) As Boolean
AllFilled = False
If Range("A" & target.Row) <> "" And Range("B" & target.Row) <> "" And Range("C" & target.Row) <> "" And _
Range("D" & target.Row) <> "" And Range("E" & target.Row) <> "" Then
AllFilled = True
End If
End Function
Private Sub Worksheet_SelectionChange(ByVal target As Range)
' When Cell A11 ("A Eleven") is selected, goto bottom of sheet
If target.Address = Range("A11").Address Then
Range("A23358").End(xlUp).Offset(0, 0).Select
End If
' 01.09.2021 Below code courtesy of JohnnyL triggers msgbox when hours exercised this month (J1) exceeds last month (J2)
'https://www.mrexcel.com/board/threads/can-anyone-explain-whats-happening-in-this-fairly-simple-code-please.1180625/page-3#posts
If Not Intersect(target, Range("J1:J2")) Is Nothing Then ' <--- Set this to the range you want
Dim sCurYearMonth As String ' Establish variable sCurYearMonth as a String
sCurYearMonth = Format(Now, "YYMM") ' Set the date variable to a yymm format eg 2109
'Application.EnableEvents = False Paul, this row was removed, don't know why
If sCurYearMonth > Range("H2").Value Then ' If this is a new month then ...
Range("H1").Value = 0 ' Set Monthly Msgbox Flag (marker cell) H1 = 0 ie. hasn't displayed yet
Range("H2").Value = sCurYearMonth ' Save the date variable into H2
End If
If (Range("J1").Value > Range("J2").Value) And (Range("H1").Value = 0) Then ' If J1 is greater than J2 & Monthly MsgBox Flag hasn't been set Then ...
Range("H1").Value = 1 ' Set Monthly Msgbox Flag H1 = 1
' Display Message box
MsgBox "Congratulations!" & vbNewLine & "You've now exercised more than you did last month! ", vbInformation, "Monthly Exercise"
End If
End If
'Application.EnableEvents = True Paul, this row was removed, don't know why
' 01.09.2021 Below code triggers msgbox when miles run this month (J4) exceeds last month (J5)
If Not Intersect(target, Range("J4:J5")) Is Nothing Then ' <--- Set this to the range you want
sCurYearMonth = Format(Now, "YYMM") ' Set the date variable to a yymm format eg 2109'
If sCurYearMonth > Range("H2").Value Then ' If this is a new month then ...
Range("H5").Value = 0 ' Set Monthly Msgbox Flag H5 = 0 ie. hasn't displayed yet
Range("H2").Value = sCurYearMonth ' Save the date variable into H2 (same as used for J1:J2 range)
End If
If (Range("J4").Value > Range("J5").Value) And (Range("H5").Value = 0) Then ' If J4 is greater than J5 & Monthly MsgBox Flag hasn't been set Then ...
Range("H5").Value = 1 ' Set Monthly Msgbox Flag H5 = 1
' Display Message box
MsgBox "Congratulations!" & vbNewLine & "You've run more miles than you did last month! ", vbInformation, "Monthly Mileage"
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal target As Range)
' Courtesy of Peter SS 09.08.2021 - replaces this formula =SWITCH(TODAY()-MAXIFS(A12:A23358,B12:B23358,"<>REST",B12:B23358,"<>"),0,"Exercised Earlier Today",1,"Last Exercise Yesterday","Last Exercise " &TEXT(MAXIFS(A12:A23358,B12:B23358,"<>REST",B12:B23358,"<>"),"d mmm"))
' and shades A8 same as either Running or Other (Row 23358 = 100th birthday :-))
' 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
Application.EnableEvents = True
End If
'15.08.2021 Line below creates CTRL (^) + \ keyboard shortcut to TLPopulateIndoorBikeEntry (FillEndRowBlue) macro in FillButtons module (shading cells for new Indoor Bike session before data input)
Application.OnKey "^\", "FillEndRowBlue"
'03.09.2021 The following creates a msgbox when the max YTD mileage and run duration have been exceeded Courtesy of Eric W 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
'WARNING FROM PETER S_Ss: If more than one cell is changed at once, the code will error (Code 13 - Type Mismatch)
'e.g. pasting rest day formatting + if you run the above FillEndRowBlue macro in FillButtons module and then drag the handle up to change the shading back to green.
'If this happens, just reset the error.
Dim MyData As Variant, OldMax As Double
Dim ThisYearRow1 As Long, ThisYearDays As Long
Dim rng As Range
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 now run for the longest time this year!", vbInformation, "Longest Run Duration YTD"
End If
'20.09.2021 For new indoor bike entry - jumps to Col F after entering data in Cols A & B - works in tandem with TLPopulateIndoorBikeEntry (FillEndRowBlue) module (activated with Control+\)
' The commented out rows are my attempt to combine the 2 but it's not working as it should. Pending solution https://www.mrexcel.com/board/threads/how-do-i-get-this-code-to-run-only-when-certain-text-is-entered-in-cells.1182301/
Dim NextRow As Long
'NextRow = Range("A" & Rows.Count).End(xlUp).Row
'Range("A" & NextRow).Resize(, 6).Interior.Color = RGB(197, 217, 241)
'Range("I" & NextRow).Resize(, 2).Interior.Color = RGB(197, 217, 241)
'Range("I" & NextRow).Value = "Indoor bike session, 60 mins."
'Range("A" & NextRow).Select
''Range("B" & NextRow).Value = "OTHER" line commented out as won't update unless this value is manually input
'If Range("B" & NextRow) = OTHER And InStr(Range("I" & NextRow), "Indoor bike session") Then
Application.EnableEvents = False
lr = Range("A" & Rows.Count).End(xlUp).Row
If target.Address(0, 0) = Range("B" & lr).Address(0, 0) Then
Range("F" & lr).Select
MsgBox "Enter heart rate", vbInformation, "Indoor Bike Session Data"
Application.EnableEvents = True
End If
'End If
'Florante Kho
'******************************
'********Modularisation********
'******************************
'This 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.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub ImportantMessages()
'**************************************************************
'*******This procedure is called in Sub WorksheetChange********
'**************************************************************
'This procedure contains all your important messages:
'NEED TO RE-ENABLE THIS 01.01.2022 (2021 commented out 09.08.2021 when 2020 total exceeded)
'If Range("IRONMAN_YTD") > Worksheets("Iron Man Log").[A201] Then 'update cell reference when location amended for new year
'If [H9] = "" Then
'MsgBox "Congratulations! You've now completed more Iron Man runs this year than the whole of last year!", vbInformation, "Iron Man Runs"
'[H9] = "1"
'End If
'End If
If Range("VBA_YTD_DAYS") = 183 Then
If [H9] = "" Then
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the bronze standard " & vbNewLine _
& "you've exercised three times a week on average this year", vbInformation, "Year to Date Exercise"
[H9] = "1"
End If
End If
If Range("VBA_YTD_DAYS") = 256 Then
If [H9] = "" Then
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the silver standard " & vbNewLine _
& "you've exercised five times a week on average this year", vbInformation, "Year to Date Exercise"
[H9] = "1"
End If
End If
If Range("VBA_YTD_DAYS") = 329 Then
If [H9] = "" Then
MsgBox "Congratulations!" & vbNewLine & vbNewLine & "You've just reached the gold standard " & vbNewLine _
& "you've exercised at least six times a week on average this year", vbInformation, "Year to Date Exercise"
[H9] = "1"
End If
End If
If Range("VBA_YTD_MILES") > 499 And Range("VBA_YTD_MILES") < 504 Then
If [H5] = "" Then
MsgBox "Congratulations! You've now run your 500th mile this year", vbInformation, "Year to Date Mileage"
[H5] = "1"
End If
End If
If Range("VBA_YTD_MILES") > 999 And Range("VBA_YTD_MILES") < 1010 Then
If [H5] = "" Then
MsgBox "Congratulations! You've now run your 1,000th mile this year", vbInformation, "Year to Date Mileage"
[H5] = "1"
End If
End If
If Range("No_MILES_RUN_SINCE_1981") > 27990 And Range("No_MILES_RUN_SINCE_1981") < 28000 Then
If [H6] = "" Then
MsgBox "You're now approaching 28,000 miles!", vbInformation, "Miles Run Since 16.04.1981"
[H6] = "1"
End If
End If
If Range("No_MILES_RUN_SINCE_1981") > 28000 And Range("No_MILES_RUN_SINCE_1981") < 28010 Then
If [H6] = "" Then
MsgBox "Congratulations! You've now run over 28,000 miles!", vbInformation, "Miles Run Since 16.04.1981"
[H6] = "1"
End If
End If
If Range("No_MILES_RUN_SINCE_1981") > 28505 And Range("No_MILES_RUN_SINCE_1981") < 28515 Then
If [H6] = "" Then
MsgBox "Congratulations! You've just run your 10,000th mile from here!", vbInformation, "Miles Run from Hallas Hall Farm"
[H6] = "1"
End If
End If
If Range("No_DAYS_SINCE_1981") = 6000 Then
If [H6] = "" Then
MsgBox "Congratulations! You've just come back from your 6,000th run!", vbInformation, "Days Run Since 16.04.1981"
[H6] = "1"
End If
End If
If Range("No_DAYS_SINCE_1981") = 7000 Then
If [H6] = "" Then
MsgBox "Congratulations! You've just come back from your 7,000th run!", vbInformation, "Days Run Since 16.04.1981"
[H6] = "1"
End If
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
'22.08.2021 The following code (courtesy of Crystalyzer www.mrexcel.com/board/threads/search-2-sheets-for-a-date.1179788/)
'Opens find date box when double clicking Cell A12>
If target.Column = 1 And target.Row > 11 Then
Call FindDate
End If
' check Target is in column H
If Cells(target.Row, "B").Value = "OTHER" Or Cells(target.Row, "B").Value = "REST" Or Cells(target.Row, "B").Value = "" Then Exit Sub ' when any cell in column H row 12 downwards is double-clicked, except OTHER, REST entries or empty cells
' Courtesy of Michael M 06.08.2021 www.mrexcel.com/board/threads/add-simple-condition-to-code-that-prevents-code-running.1178458/
If target.Column = 8 And target.Row >= 12 Then
Cancel = True
TopCell = Cells(12, 3).Address 'Row 12, Column 3 i.e. mileage
BottomCell = Cells(target.Row, 3).Address
TotalCalc = Application.WorksheetFunction.Sum(Range(TopCell, BottomCell))
MsgBox "Total miles run to " & Format(Cells(ActiveCell.Row, 1), "dd mmmm yyyy: ") & _
Format((CLng(10724.97 + TotalCalc)), "#,##0") & " ", vbOKOnly, "Lifetime Mileage"
End If
End Sub
Sub xx()
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub