Color cell when date is more than 40 days

[Sha]

Hi

this is the code I have thus far.


Sub HighlightCells()

Dim dtrg As Range 'Date in Col J
Dim dtCell As Range 'Date Cell
Set dtrg = Range("J1:J3000") ' Date Range

For Each dtCell In dtrg.Cells
If dtCell.Value > dtCell.value + 40 Then
dtCell.Interior.ColorIndex = 3
End If
Next dtCell


End Sub

 

[Sha]

the code is placed at the ever end of all the codes that I have. I only have 1 sheet.

Public MAIL_WHO As String
Public XMAILBODY As String
Public SUBJECT_MESSAGE As String
Private Sub Worksheet_Change(ByVal Target As Range)


If Target.Column <> 16 And Target.Column <> 15 And Target.Column <> 14 Then Exit Sub
If Target.Value = "" Then Exit Sub


If Target.Column = 16 Then
    MAIL_WHO = "Linda@gmail.com"
    SUBJECT_MESSAGE = "Pending query processing" 'adds subject to email
   XMAILBODY = "Hi there" & vbNewLine & vbNewLine & _
        "Coding Query from: " & Range("E" & Target.Row).Value & vbNewLine & vbNewLine & _
        "Patient Name: " & Range("B" & Target.Row).Value & vbNewLine & vbNewLine & _
        "Case Number: " & Range("C" & Target.Row).Value & " (" & Range("D" & Target.Row).Value & ")" & vbNewLine & vbNewLine & _
        "Admission Date: " & Range("H" & Target.Row).Value & vbNewLine & vbNewLine & _
        " Discharge date: " & Range("J" & Target.Row).Value & vbNewLine & vbNewLine & _
        "Coding Query: " & Range("P" & Target.Row).Value & vbNewLine & vbNewLine & _
        "Thank you" & vbNewLine 'calling out and placing values of each col into email body
        
End If


If Target.Column = 15 Then
    If Target.Offset(0, -10) = "" Then Exit Sub
    If Target.Offset(0, -10) = "TL" Then MAIL_WHO = "Traves_lee@gmail.com"
    If Target.Offset(0, -10) = "KL" Then MAIL_WHO = "Kris_Loen@gmail.com"
    If Target.Offset(0, -10) = "RS" Then MAIL_WHO = "Rose@gmail.com"
    SUBJECT_MESSAGE = "Mental Incapacity updated" 'adds subject to email
    XMAILBODY = "Hi there" & vbNewLine & vbNewLine & _
        "Mental Incapacity updated as : " & Range("N" & Target.Row).Value & vbNewLine & _
        "Case Number: " & Range("C" & Target.Row).Value & " (" & Range("D" & Target.Row).Value & ")" & vbNewLine & "Thank you" 'calling out and placing values of each col into email body
End If

If Target.Column = 14 Then
    If Target.Offset(0, -9) = "" Then Exit Sub
    If Target.Offset(0, -9) = "TL" Then MAIL_WHO = "Traves_lee@gmail.com"
    If Target.Offset(0, -9) = "KL" Then MAIL_WHO = "Kris_Loen@gmail.com"
    If Target.Offset(0, -9) = "RS" Then MAIL_WHO = "Rose@gmail.com"
    'MAIL_WHO = "Linda@gmail.com"
    SUBJECT_MESSAGE = "Conditions Arises updated" 'adds subject to email
    XMAILBODY = "Hi there" & vbNewLine & vbNewLine & _
        "Conditions Arises updated : " & Range("N" & Target.Row).Value & vbNewLine & _
        "Case Number: " & Range("C" & Target.Row).Value & " (" & Range("D" & Target.Row).Value & ")" & vbNewLine & "Thank you" 'calling out and placing values of each col into email body
End If

 

Mail_small_Text_Outlook

End Sub


Sub Mail_small_Text_Outlook()

Dim xOutApp As Object
Dim xOutMail As Object

Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)

On Error Resume Next
With xOutMail
    .To = MAIL_WHO
    .Subject = SUBJECT_MESSAGE
    .Body = XMAILBODY
    .Display 'or .send
End With
On Error GoTo 0

Set xOutMail = Nothing
Set xOutApp = Nothing

End Sub


Sub HighlightCells()

    Dim dtrg As Range: Set dtrg = Range("J1:J3000")
    Dim dtCell As Range

    For Each dtCell In dtrg.Cells
        If dtCell.Value <> "" And dtCell.Value < Date - 40 Then _
           dtCell.Interior.ColorIndex = 3
    Next dtCell

End Sub

 

[MARK858]

Please answer all the questions that I asked and try running the code by itself as you are not calling the code in your code that you posted (put the code in a regular module, click in the code and press F5)

 

[Sha]

ok I will try that.

 

[Sha]

HI there,

I have managed to get the code to work! thank you so much!

 

[MARK858]

You're welcome (hopefully now you have tested the code separately you have put a line in the event code to call the sub).