Change range in worksheet_change event code every Jan 1?

[Ironman]

I've just been very kindly given the below code by Eric W relating to this post

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyData As Variant, OldMax As Double

    If Not Intersect(Target, Range("C8413:C8777")) Is Nothing Then
        MyData = Range("C8413:C8777").Value
        MyData(Target.Row - 8413 + 1, 1) = ""
        OldMax = WorksheetFunction.Max(MyData)
        If Target.Value > OldMax Then MsgBox "Maximum distance achieved"
    End If
    
    If Not Intersect(Target, Range("D8413:D8777")) Is Nothing Then
        MyData = Range("D8413:D8779").Value
        MyData(Target.Row - 8413 + 1, 1) = ""
        OldMax = WorksheetFunction.Max(MyData)
        If Target.Value > OldMax Then MsgBox "Maximum time achieved"
    End If
    
End Sub

I'd be grateful, if it's possible, for the above ranges to be changed automatically each year on Jan 1 by the number of days in the year (i.e. taking account of leap years)

e.g. On 1 Jan 2022 both ranges will change from C8413:C8777 and D8413:D8777 to C8778:C9142 and D8778:D9142

Many thanks!

 

[Peter_SSs]

Glad we got there in the end.

Don't forget to change those back to Year(Date) if you happened to have changed in your main file.

 

[Ironman]

Yes, and thank you for your patience with me

 

[Peter_SSs]

No problem.

 

[Ironman]

Hi Peter

I need to adapt your above code to another sheet but I'm afraid it's too complex for me to understand. To recap, the objective is to generate a message box when 1) max YTD mileage and 2) max YTD run duration have been exceeded.

The other sheet range for 2021 begins on row 283. The mileage is still column C but I now need column H instead (maximum watts output).

I don't know if this is relevant but the other difference is the dates in Col A have gaps e.g. the first entry for 2021 is row 283 but it's April 21 (i.e. not Jan 1) and row 284 is April 25 (4 day gap).

MrExcel.xlsx
	A	B	C	D	E	F	G	H
282	Wed, 30 Dec 2020	1:00:00	24.2	15.0	7	136	84%	148
283	Wed, 21 Apr 2021	1:00:00	19.7	12.2	7	134	83%	120
284	Sun, 25 Apr 2021	1:00:00	19.9	12.4	7	133	83%	121
Indoor Bike

Cell Formulas
Range	Formula
D282:D284	D282	=IF(B282>0,C282*0.621,"")
G282:G284	G282	=F282/(220-(DATEDIF($F$1,A282,"Y")))

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
H283:H405	Cell Value	top 3 values	text	NO
H283:H405	Cell Value	top 10% values	text	NO
H283:H405	Cell Value	above average	text	NO
D283:D405	Cell Value	top 3 values	text	NO
D283:D405	Cell Value	top 10% values	text	NO
G11:G405	Cell Value	>=0.8	text	NO
G11:G405	Cell Value	between 0.7 and 0.799	text	NO
G11:G405	Cell Value	between 0.6 and 0.7	text	NO
G11:G405	Cell Value	between 0.5 and 0.6	text	NO
D283:D405	Cell Value	above average	text	NO

Would it still be possible for a message box to be created for both events, as per your solution?

Many thanks!

P.S. You did make it clear that the code would error when more than one cell is changed at once. I didn't realise at the time that this included any changes in formatting. Is there any way round this? If it makes it too difficult then it's fine, at least I know!

 

[Peter_SSs]

I am assuming that you are always just adding data at the bottom so this only checks upwards to see if the entry in column H is the highest so far this year.
The 'Exit Sub' line will ensure that the rest of the code only runs if a single cell is changed. You could add a similar line near the top of the other codes to stop that error when multiple cells are changed at once.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long, ThisYear As Long
  Dim MaxWatts As Double
   
  If Target.CountLarge > 1 Then Exit Sub  'Exit if multiple cells changed
  If Target.Column = 8 Then               'If Column H then proceed
    With Cells(Target.Row, "A")
      If IsDate(.Value) Then
        ThisYear = Year(Date)
        If Year(.Value) = ThisYear Then
          Do Until Year(.Offset(-i - 1).Value) <> ThisYear
            i = i + 1
            If .Offset(-i, 7).Value > MaxWatts Then MaxWatts = .Offset(-i, 7).Value
          Loop
          If Target.Value >= MaxWatts Then MsgBox "Maximum watts " & IIf(Target.Value = MaxWatts, "equalled", "achieved")
        End If
      End If
    End With
  End If
End Sub

 

[Ironman]

Hi Peter, thanks ever so much - the above works perfectly!

Re the max miles code - I copied this across and although it doesn't error, there is no message box.

There is 1 other change event in the sheet - I don't know if this is affecting it, but it didn't affect your code above.

Here are all 3:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long
Application.ScreenUpdating = False
lr = Range("A" & Rows.Count).End(xlUp).Row

' jump from C to H on that same row
If Target.Address(0, 0) = Range("C" & lr).Address(0, 0) Then
    Range("H" & lr).Select
    MsgBox "Enter Average Watts", vbInformation, "Indoor Bike Session Data"
End If

If Target.Address(0, 0) = Range("H" & lr).Address(0, 0) Then
    Range("J" & lr).Select
End If
Application.Calculation = xlCalculationAutomatic

'for max miles - copied this from Training Log sheet
    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
    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 cycled the furthest number of miles this year!", vbInformation, "Distance cycled YTD"
    End If
  
'for max watts
  Dim i As Long, ThisYear As Long
  Dim MaxWatts As Double
  
  If Target.CountLarge > 1 Then Exit Sub  'Exit if multiple cells changed
  If Target.Column = 8 Then               'If Column H then proceed
    With Cells(Target.Row, "A")
      If IsDate(.Value) Then
        ThisYear = Year(Date)
        If Year(.Value) = ThisYear Then
          Do Until Year(.Offset(-i - 1).Value) <> ThisYear
            i = i + 1
            If .Offset(-i, 7).Value > MaxWatts Then MaxWatts = .Offset(-i, 7).Value
          Loop
          If Target.Value >= MaxWatts Then MsgBox "Maximum watts " & IIf(Target.Value = MaxWatts, "equalled YTD", "achieved YTD")
        End If
      End If
    End With
  End If

End Sub

Hope you can help?

Thanks again.

Edit: your error fix worked perfectly, thank you!

 

[Peter_SSs]

You said this was another sheet, but you seem to be applying code from the original sheets we dealt with?

Are we actually just dealing with one sheet and trying to MsgBox if any one of a number of "max" values are achieved?

If so, have we gone away from the situation where every date for the year was listed to now only having "occasional" dates in column A.

Is the process of only looking upwards from the changed cell for current year dates okay to rely on?

BTW a simpler way to write lines like

If Target.Address(0, 0) = Range("C" & lr).Address(0, 0) Then

is

If Target.Address(0, 0) = "C" & lr Then

 

[Ironman]

Hi Peter, sorry for the confusion.

Yes it's another sheet (cycling rather than running) - hence why this one has "occasional" dates rather than every day of the year.

Is the process of only looking upwards from the changed cell for current year dates okay to rely on?

Yes it is.

I've looked again at the code you wrote and managed to get to grips with it and I applied it to the max miles code, as below, which now works (the code above it wasn't affecting it)

  Dim i2 As Long, ThisYear2 As Long
  Dim MaxMiles As Double
   
  If Target.CountLarge > 1 Then Exit Sub  'Exit if multiple cells changed (avoids VBA error when more than 1 cell is amended at once)
  If Target.Column = 3 Then               'If Column H then proceed
    With Cells(Target.Row, "A")
      If IsDate(.Value) Then
        ThisYear2 = Year(Date)
        If Year(.Value) = ThisYear2 Then
          Do Until Year(.Offset(-i2 - 1).Value) <> ThisYear2
            i2 = i2 + 1
            If .Offset(-i2, 2).Value > MaxMiles Then MaxMiles = .Offset(-i2, 2).Value
          Loop
          If Target.Value >= MaxMiles Then MsgBox "Maximum session distance " & IIf(Target.Value = MaxMiles, "equalled YTD", "achieved YTD")
        End If
      End If
    End With
  End If

Thanks for the tip BTW, I'll amend the code.

 

[Peter_SSs]

So, you are right to go with no more help required here at the moment?

 

[Ironman]

So, you are right to go with no more help required here at the moment?

Yes, it's OK now - and thank you very much for asking.