If date in cell is older than todays date by 1 month Then Font RED

[ipbr21054]

Hi,
On my worksheet in column H i have dates of when i quoted for a job.
My goal is to check each date with todays date & if more than 1 moth old have that rows Font vbRed.

So my setup is like this.
Headers in Row 1
Dates are all in column H
Values start Row 2 & down the page.
Cells in use are column A to L
Worksheet is called QUOTES

So when the worksheeet QUOTES is open the code will run.
The code will check the date in column H with todays date.
Any date that is older than 1 month will have that rows cells Font changed to vbRed

 

[Peter_SSs]

Any reason not to just use Conditional Formatting?

24 10 15.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1								Quote Date
2								7/10/2024
3								19/09/2024
4								6/09/2024
5								10/09/2024
6								18/09/2024
7								7/10/2024
8								9/09/2024
9								4/09/2024
10
11
12								6/09/2024
13								25/09/2024
14								4/09/2024
15								12/09/2024
16								15/10/2024
17								7/09/2024
18								20/09/2024
19
20								25/08/2024
QUOTES

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A2:L20	Expression	=AND($H2<EDATE(TODAY(),-1),$H2<>"")	text	NO

 

[ipbr21054]

I like to use vba so i can refer to it later,use it again & try & learn by it.

 

[ipbr21054]

I have tried the following but it has no affect at all ?

Do you see why that may be

If Sheets("QUOTES").Range("H2").Value > DateAdd("m", 1, Date) Then
Range("A2:L2").Font.Color = vbRed
End If

 

[mumps]

Try some code to filter the data based on column H using your criteria and then set the color for the visible range to red then remove the filter.

 

[ipbr21054]

Not sure i understand & its taken me a good while to produce the above

 

[mumps]

Perhaps you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here (de-sensitized if necessary).

 

[ipbr21054]

I would like to continue with it myself to see how i get on but do you see an issue with the code i have supplied,looking at it i see it should work but makes no difference

 

[mumps]

Change > to <.

 

[Peter_SSs]

Using the AutoFilter approach an option might be

Sub ApplyRed()
  Application.ScreenUpdating = False
  With Sheets("QUOTES")
    .AutoFilterMode = False
    With .Range("A1:L" & .Range("H" & Rows.Count).End(xlUp).Row)
      .AutoFilter Field:=8, Criteria1:="<" & CLng(DateAdd("m", -1, Date)), Operator:=xlAnd, Criteria2:="<>"
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then .Offset(1).Resize(.Rows.Count - 1).Font.Color = vbRed
    End With
    .AutoFilterMode = False
  End With
  Application.ScreenUpdating = True
End Sub