VBA script to colour cell based on date.

[timcpugh]

Hello there, I'm trying to create a VBA script to colour the cells in column H automatically based on the date.
If the cell is blank no formatting.
If the cell is equal to TODAY fill with orange
If the cell is before TODAY fill with red
If the cell is greater than TODAY will with Blue

Thanks in advance!

[HansV]

You can do that without VBA by creating three conditional formatting rules. If you don't want to use conditional formatting, should the code run automatically when a cell in column H is edited? If so:
Right-click the sheet tab.
Select 'View Code' from the context menu.
Copy the following code into the worksheet module:

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    If Not Intersect(Range("H2:H" & Rows.Count), Target) Is Nothing Then
        Application.ScreenUpdating = False
        For Each rng In Intersect(Range("H2:H" & Rows.Count), Target)
            If IsDate(rng.Value) Then
                Select Case rng.Value
                    Case Is < Date
                        rng.Interior.Color = vbRed
                    Case Date
                        rng.Interior.Color = RGB(255, 192, 0)
                    Case Is > Date
                        rng.Interior.Color = RGB(0, 255, 255)
                End Select
            Else
                rng.Interior.ColorIndex = xlColorIndexNone
            End If
        Next rng
        Application.ScreenUpdating = True
    End If
End Sub

[timcpugh]

Thanks Hans,
how can we refresh the script each day to update based on today's date, because at the moment it only updates when the cell is changed?

[HansV]

Do you really want VBA? Using conditional formatting would be much easier and always be up-to-date.

[timcpugh]

Hello Han, the reason being i'm using the following scripts to move lines up and down and when using conditional formatting it's keeps creating copies of the rules each time i move the lines.

Code: Select all

Sub RowsDown1()
    With Selection.EntireRow
        .Cut
        .Offset(.Rows.Count + 1).Insert
        .Select
    End With
End Sub


Sub RowUp()
    With Selection.EntireRow
         .Cut
         .Offset(-1, 0).Insert Shift:=xlDown
         .Select
    End With
End Sub

[HansV]

Create the following code in the ThisWorkbook module:

Code: Select all

Private Sub Worksheet_Open()
    Dim wsh As Worksheet
    Dim rng As Range
    Application.ScreenUpdating = False
    ' Change sheet name as needed
    Set wsh = Worksheets("Sheet1")
    For Each rng In Intersect(wsh.Range("H2:H" & wsh.Rows.Count), wsh.UsedRange)
        If IsDate(rng.Value) Then
            Select Case rng.Value
                Case Is < Date
                    rng.Interior.Color = vbRed
                Case Date
                    rng.Interior.Color = RGB(255, 192, 0)
                Case Is > Date
                    rng.Interior.Color = RGB(0, 255, 255)
            End Select
        Else
            rng.Interior.ColorIndex = xlColorIndexNone
        End If
    Next rng
    Application.ScreenUpdating = True
End Sub

The code will be run each time the workbook is opened.

[timcpugh]

Perfect thanks Hans!