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!

 

[Ironman]

I've hit a bit of a snag with the code in Post #18:

Private Sub Workbook_Open()
  With Sheets("Training Log").Range("B12")
    .Value = .Value
  End With
End Sub

As it only updated when I opened the workbook, it went 'out of date' as soon as I made a new entry (and would only update the next time I opened the workbook). I therefore had to change it to this event

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'With Sheets("Training Log").Range("B12")
   .Value = .Value
  End With
End Sub

so it would update whenever I saved it.

However, today, I added this code that creates a link in Training Log B1 to the last active cell in the workbook

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = Worksheets("Training Log")
 
    ws.Hyperlinks.Add Anchor:=ws.Range("B1"), Address:="", SubAddress:= _
          "'" & Sh.Name & "'" & "!" & Target.Address(0, 0), ScreenTip:="Go to last active cell", TextToDisplay:="ACTIVITY"
    With ws.Range("B1")
.Font.FontStyle = "Segoe UI"
.Font.Size = 9
.Font.Bold = True
End With
End Sub

The new macro works perfectly apart from whenever I save the workbook and then the link to the last active cell reverts to cell B12 and I don't know why, or how to prevent this happening.

Can the code be modified so both of these macros work as they should?

Many thanks!

 

[Peter_SSs]

As it only updated when I opened the workbook, it went 'out of date' as soon as I made a new entry (and would only update the next time I opened the workbook). I therefore had to change it to this event

Where exactly did you make a new entry? Remember the post #12 code was only set up to update A8 of 'Training Log' when a cell in column B of that sheet had an entry made.
If you opened the workbook and then made an entry in column B of 'Training Log' and A8 did not update then it sounds like your vba 'events' are becoming disabled.

That can happen if some vba code errors while events are disabled and the code is exited before events are re-enabled, or of there is some other vba in the workbook that is being triggered or run manually and that code is disabling events and not re-enabled them. The exact circumstances are very difficult to diagnose from afar.

What I can say is that I have a test workbook with the post #12 code and the post #18 code. When I open the workbook, A8 of 'Training Log' gets updated. If I then make entries in 'Training Log' that are in column B, A8 again gets updated.

 

[Ironman]

Hi Peter

The new entry was made in column B.

I have just moved the code back to the Workbook_Open event but inserted it further down than it was and it updates fine now. I guess from the other entries you can see why it didn't work before and it does now?

Private Sub Workbook_Open()
    
 '--2/2/18 this allows VBA to modify 2 protected sheets "Training Log" and "Daily Tracking" without unprotecting
 'You temporarily restarted it to protect Last 90 Bike Data but then discovered it wouldn't update so re-commented it out
 With ThisWorkbook
   Call UnprotectWorksheet(wks:=.Sheets("Training Log"))
   Call UnprotectWorksheet(wks:=.Sheets("Daily Tracking"))
   Call UnprotectWorksheet(wks:=.Sheets("Training 1981-1997"))
   Call ProtectWorksheet(wks:=.Sheets("Daily Tracking"))
 End With

    With Application
         .DisplayFullScreen = False ' added this code 03.2012 as Watch Rotation workbook is viewed with full screens
         Application.WindowState = xlMaximized
    End With
    
'Line below ensures Training Log always opens at the last entry
'If you want the active cell to be the first blank cell, change last part to .Offset(1, 0).Select

Sheets("Training Log").Select
Range("A23358").End(xlUp).Offset(0, 0).Select 'sets active cell to last filled row
'Following line ensures wav file is not interrupted when OK'ing msgbox.  If you want to cut it short, comment out this line.
'Dim Wait As Boolean

Dim wavefile, x

wavefile = "D:\Sounds\BornToRun.wav"

Call sndPlaySound32(wavefile, SND_ASYNC Or SND_FILENAME)

CreateMYtoolbar

Application.EnableEvents = False

Dim rMaxValues As Range
Set rMaxValues = Worksheets("Weekly Tracking").Cells(264, Year(Now) - 1984).Resize(1, 2)
rMaxValues.Offset(5, 0).Value = rMaxValues.Value
Set rMaxValues = Worksheets("Monthly Tracking").Cells(60, Year(Now) - 1983).Resize(1, 2)
rMaxValues.Offset(4, 0).Value = rMaxValues.Value

Dim rCell As Range
Dim sAddress As String, sLessThan As String
sLessThan = Chr$(34) & "<" & Chr$(34)
With Sheets("Address Tracking")
  Set rCell = .[b2].End(xlToRight)
  .[a6].Value = rCell.Column - 1
  sAddress = Range(.[b2], rCell.Offset(0, -1)).Address(0, 0)
  .[b6].Formula = "=COUNTIF(" & sAddress & "," & sLessThan & "&" & rCell.Address(0, 0) & ")"
  .[c6].Value = .[b6].Value
  Set rCell = .[b4].End(xlToRight)
  sAddress = Range(.[b4], rCell.Offset(0, -1)).Address(0, 0)
  .[d6].Formula = "=COUNTIF(" & sAddress & "," & sLessThan & "&" & rCell.Address(0, 0) & ")"
  .[E6].Value = .[d6].Value
  .Range("A6:E6").Font.ColorIndex = 2  ' white, to make contents invisible
End With

Application.EnableEvents = True

With Sheets("Training Log").Range("B12")
    .Value = .Value
  End With

Dim iYear As Integer
iYear = iGetLogYear()

If iYear <> Year(Date) Then
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  
  iYear = Year(Date)   'the new year
  
  MsgBox "Welcome to " & iYear & " Paul - You're now into running year " & iYear - 1981 & "!   ", _
      vbInformation, "Happy New Year Paul!"
  
  Call Worksheets("Daily Tracking").NewYearUpdate(iYear)
  Call Worksheets("Weekly Tracking").NewYearUpdate(iYear)
  Call Worksheets("Monthly Tracking").NewYearUpdate(iYear)
  Call Worksheets("Run Freq").NewYearUpdate(iYear)
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  MsgBox "All Tracking sheets have been updated for " & iYear
End If

'PetesNewStuff
Answer = MsgBox("Do you need to add run data?", vbYesNo + vbQuestion, "Exercise Log")
 If Answer = vbNo Then
 Else
 Application.Run ("AddNewRunData")
 End If

End Sub

 

[Peter_SSs]

Glad you have it working. Thanks for letting us know.