Code needed instead of existing formula to match fill colour of cell

[Ironman]

Hi

The below formula relates to Post #9 of this thread

SWITCH(TODAY()-MAXIFS(A12:A36000,B12:B36000,"<>REST",B12:B36000,"<>"),0,"Last Exercise Today",1,"Last Exercise Yesterday","Last Exercise " &TEXT(MAXIFS(A12:A36000,B12:B36000,"<>REST",B12:B36000,"<>"),"dd/mm/yyy"))

The below are Columns A & B from the most recent entries from sheet 'Training Log' that runs from A12:A36000

Sun, 1 Aug 2021	Cullingworth Rd/Viaduct/ Stn Road/Old Allen Road Back Lane/Wilsden Rd/ Cottingley Rd/Lee Lane/ Cross Lane/Coplowe Ln/ Crack Lane/Main Street/ Harden Ln/Mill Hill Top/ Wilsden Rd/Mad Mile/ Greenside Lane (21/02/2020)
Mon, 2 Aug 2021	OTHER
Tue, 3 Aug 2021	REST
Wed, 4 Aug 2021	OTHER
Thu, 5 Aug 2021	Hallas Br/Down Bents Ln Harden Lane/Smithy Ln/ Lee Farm/Black Hills/ Golf Course/R down Beck Foot Lane/Wagon Lane/ Up LLC to cannon monument/Back to 3-Rise Locks & over Br/ Brown Cow/Main Road all the way back home (22/04/2007)
Fri, 6 Aug 2021	OTHER
Sat, 7 Aug 2021	REST
Sun, 8 Aug 2021	OTHER

The formula above returns the most recent exercise activity date and works perfectly. However, I've been extremely reliably informed that what I now need in addition can only be done using VBA, and it would probably be a neater solution if it replaced the above formula as well.

I need the result cell (A8) fill colour to match the colour of the relevant cell. For the above table, this means I need the result cell to be filled the same colour (blue) as the most recent cell in column B that is not "REST".

I guess that's clear, but here's another table for another example

Mon, 2 Aug 2021	OTHER
Tue, 3 Aug 2021	REST
Wed, 4 Aug 2021	OTHER
Thu, 5 Aug 2021	Hallas Br/Down Bents Ln Harden Lane/Smithy Ln/ Lee Farm/Black Hills/ Golf Course/R down Beck Foot Lane/Wagon Lane/ Up LLC to cannon monument/Back to 3-Rise Locks & over Br/ Brown Cow/Main Road all the way back home (22/04/2007)

If this was the most recent exercise, I would expect the fill colour of the result cell A8 in this instance to be the same shade of green.

A solution would be greatly appreciated.

Many thanks!

 

[Peter_SSs]

Give this a try

Sub LastExercise()
  Dim r As Long, Clr As Long
  Dim Txt As String
  
  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 = .Cells(r, 1).Text
    End Select
    Clr = .Cells(r, 1).Interior.Color
  End With
  With Range("A8")
    .Value = "Last Exercise " & Txt
    .Interior.Color = Clr
  End With
End Sub

 

[Ironman]

Many thanks once again Peter that works perfectly with a toolbar icon

How would this be activated automatically please?

Would I need to insert this code first?

Private Sub Worksheet_Change(ByVal Target As Range)

 

[Peter_SSs]

How would this be activated automatically

What should trigger the update? Perhaps manually typing in another row or two in the table? Something else?

 

[Ironman]

Yes, manually typing a new row. I would expect A8 to change as soon as data has been entered into Columns A and B.

 

[Peter_SSs]

Then try this Worksheet_Change event code (slightly modified from above). To implement ..
1. Right click the sheet name tab and choose "View Code".
2. Copy and Paste the code below into the main right hand pane that opens at step 1.
3. Close the Visual Basic window & test.

Private Sub Worksheet_Change(ByVal Target As Range)
  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 = .Cells(r, 1).Text
      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
End Sub

 

[Ironman]

Thanks again Peter

Row

If Not Intersect(Target, Columns("B")) Is Nothing Then

returns

Error 424 Object Required

It's probably because I have some other code under the same 'heading'

Private Sub Worksheet_Change(ByVal Target As Range)

 

[Ironman]

Apologies - I found the issue - it works perfectly, thank you so much for all your time and help Peter

 

[Peter_SSs]

Cheers. Glad you found & resolved the issue.

 

[Ironman]

Hi again

re the above code, the 'Case Else' applies today.

        Case Else: Txt = .Cells(r, 1).Text
      End Select
      Clr = .Cells(r, 1).Interior.Color
    End With
    Application.EnableEvents = False
    With Range("A8")
      .Value = "Last Exercise " & Txt

Although the text is all visible below because of the xl2bb code, the text is too much for the cell in my sheet.

Last Exercise Tue, 10 Aug 2021

Can this be modified so it's the equivalent of "Last Exercise " & the date in the format dd mmmm please?

Many thanks!