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)
If target.Address = Range("A11").Address Then
Range("A23358").End(xlUp).Offset(0, 0).Select
End If
If Not Intersect(target, Range("J1:J2")) Is Nothing Then
Dim sCurYearMonth As String
sCurYearMonth = Format(Now, "YYMM")
If sCurYearMonth > Range("H2").Value Then
Range("H1").Value = 0
Range("H2").Value = sCurYearMonth
End If
If (Range("J1").Value > Range("J2").Value) And (Range("H1").Value = 0) Then
Range("H1").Value = 1
MsgBox "Congratulations!" & vbNewLine & "You've now exercised more than you did last month! ", vbInformation, "Monthly Exercise"
End If
End If
If Not Intersect(target, Range("J4:J5")) Is Nothing Then
sCurYearMonth = Format(Now, "YYMM")
If sCurYearMonth > Range("H2").Value Then
Range("H5").Value = 0
Range("H2").Value = sCurYearMonth
End If
If (Range("J4").Value > Range("J5").Value) And (Range("H5").Value = 0) Then
Range("H5").Value = 1
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)
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
Application.OnKey "^\", "FillEndRowBlue"
Dim MyData As Variant, OldMax As Double
Dim ThisYearRow1 As Long, ThisYearDays As Long
Dim rng As Range
Const BaseRow As Long = 8413
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)
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
Dim NextRow As Long
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
Call ImportantMessages
Application.Calculation = CALC
Application.Calculate
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub ImportantMessages()
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)
If target.Column = 1 And target.Row > 11 Then
Call FindDate
End If
If Cells(target.Row, "B").Value = "OTHER" Or Cells(target.Row, "B").Value = "REST" Or Cells(target.Row, "B").Value = "" Then Exit Sub
If target.Column = 8 And target.Row >= 12 Then
Cancel = True
TopCell = Cells(12, 3).Address
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