Colouring Cells based on Date

[DrH100]

I am currently using a piece of code (within a bigger piece) that colours the dates in two columns based on how close it is to the current date. It works fine but sometimes the sheet it is looking in has over 3500 rows so it is taking for ever (well over 6 mins)

The code is

Sub ColDate() 'date case opened
application.ScreenUpdating = False
    Dim MyRg As Range
    Dim F As Range
    Dim DateDiff As Long
    
   
    Set MyRg = Range("g1:h" & Range("H" & Rows.Count).End(xlUp).Row)
    For Each F In MyRg
        If ((F <> Empty) And IsDate(F)) Then
            DateDiff = Int(Date - F.Value)
            F.Offset(0, 0).Interior.ColorIndex = xlNone
            If ((DateDiff >= -10000) And (DateDiff <= 28)) Then F.Offset(0, 0).Interior.ColorIndex = 50
            If ((DateDiff >= 29) And (DateDiff <= 56)) Then F.Offset(0, 0).Interior.ColorIndex = 35
            If ((DateDiff >= 57) And (DateDiff <= 91)) Then F.Offset(0, 0).Interior.ColorIndex = 33
             If ((DateDiff >= 92) And (DateDiff <= 182)) Then F.Offset(0, 0).Interior.ColorIndex = 45
             If ((DateDiff >= 183) And (DateDiff <= 365)) Then F.Offset(0, 0).Interior.ColorIndex = 26
             If ((DateDiff >= 366) And (DateDiff <= 100000)) Then F.Offset(0, 0).Interior.ColorIndex = 3
        End If
    Next F
    application.ScreenUpdating = True
   End Sub

Are there any suggestions to improve this piece of code or make it faster.

If its how it has to be so be it but I'd like to shave some time off if possible.

Many thanks

 

[Gary McMaster]

The "SpecialCells" method may help if there are a lot of empty cells. It would include only cells that contain something which would also allow you to get rid of the "F <> Empty" test.

Hope that helps.

Gary

Sub ColDate() 'date case opened

Application.ScreenUpdating = False
    Dim MyRg As Range
    Dim F As Range
    Dim DateDiff As Long
    
    'Set MyRg = Range("g1:h" & Range("H" & Rows.Count).End(xlUp).Row)
    Set MyRg = Range("g1:h" & Range("H" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeConstants)
    For Each F In MyRg
        If IsDate(F) Then
            DateDiff = Int(Date - F.Value)
            F.Offset(0, 0).Interior.ColorIndex = xlNone
            If ((DateDiff >= -10000) And (DateDiff <= 28)) Then F.Offset(0, 0).Interior.ColorIndex = 50
            If ((DateDiff >= 29) And (DateDiff <= 56)) Then F.Offset(0, 0).Interior.ColorIndex = 35
            If ((DateDiff >= 57) And (DateDiff <= 91)) Then F.Offset(0, 0).Interior.ColorIndex = 33
             If ((DateDiff >= 92) And (DateDiff <= 182)) Then F.Offset(0, 0).Interior.ColorIndex = 45
             If ((DateDiff >= 183) And (DateDiff <= 365)) Then F.Offset(0, 0).Interior.ColorIndex = 26
             If ((DateDiff >= 366) And (DateDiff <= 100000)) Then F.Offset(0, 0).Interior.ColorIndex = 3
        End If
    Next F
    Application.ScreenUpdating = True
    
   End Sub