Minor amendment needed for code to run

[Ironman]

Hi

The following code in the worksheet_change event is triggered when any text value other than 'OTHER' and 'REST' is input in column B in the last filled row. The input text "Double click for lifetime mileage total up to this date" is then added to the validation in Column H.

If target.Column = 2 And target.Value <> "OTHER" And target.Value <> "REST" Then
    Application.EnableEvents = False
    With Range("A23358").End(xlUp).Offset(1, 7).Validation
         .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
         .InputMessage = "Double click for lifetime mileage total up to this date"
         .ShowInput = True
       End With
   Application.EnableEvents = True
End If

I'm pretty close, but I can't quite get the first 3 lines right for the code to run.

Help would be appreciated.

Many thanks!

 

[Ironman]

Ahh, thanks for stepping in Joe, I've just got it to run!

If target.Column = 2 And target.Value <> "OTHER" And target.Value <> "REST" And target.Value <> "" Then
       With Range("H" & 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

I've just found a slight issue though - would you perhaps be able to amend the first line to If target.Column = 9 and the text starts with "Day" instead?

Many thanks!

 

[Joe4]

I've just found a slight issue though - would you perhaps be able to amend the first line to If target.Column = 9 and the text starts with "Day" instead?

Can you please post the ENTIRE block of code, including the "Private Sub..." and "End Sub" lines?

Changing the column number in your criteria is straightforward enough. You already have it checking another column. Just change the number.
To check if something starts with a word like "Day", you can do:

Left(Target.Value,3) = "Day"

or

Left(Target.Value,3) <> "Day"

for "NOT" matching.

 

[Ironman]

Thanks for that Joe
The issue I had wasn't an error, it was just the order of events - it made more sense for column 8 to respond to a change in column 9 than column 2. Here's the entire code anyway, which is all OK - thanks again.

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
 
 
    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


Dim NextRow As Long

lr = Range("A" & Rows.Count).End(xlUp).Row

If target.Column = 2 And target.Value = "OTHER" Then
    Application.EnableEvents = False
Range("A" & target.Row).Resize(, 6).Interior.Color = RGB(197, 217, 241)
Range("I" & target.Row).Resize(, 2).Interior.Color = RGB(197, 217, 241)
    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 Heart Rate", vbInformation, "Indoor Bike Session Data"
End If
Application.EnableEvents = True
' 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
End If

'Adapted from the above to fill row grey for REST entries
If target.Column = 2 And target.Value = "REST" Then
    Range("A" & target.Row).Resize(, 10).Interior.Color = RGB(217, 217, 217)
    Application.EnableEvents = False
    'select cell col I
    Range("A23358").End(xlUp).Offset(1, 0).Select
    Application.EnableEvents = True
End If

'Adapted from the above for running entries to replace validation dropdown with input msg
If target.Column = 9 And Left(Target.Value,3) = "Day"
   Application.EnableEvents = False
       With Range("H" & Rows.Count).End(xlUp).Validation
         .Delete
         .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
         .InputMessage = "Double click for lifetime mileage total up to this date"
         Application.EnableEvents = True
         .ShowInput = True
       End With
       End If
      
Application.Calculation = CALC
Application.Calculate
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[Joe4]

You are welcome.
Glad you got it sorted out.