Trigger email and retrieve data from other cells when a cell color changes.

[Sha]

Not sure why the code is not working. Could anyone help? I am trying to trigger an email when a call changes colors and at the same time retrieve information from other cells.
For example, if cell J38 changes to red email content will be info from cells, A38, J37, and B35, (Tricia, 9, Dec 23). The email is triggered but no content was retrieved.

Could anyone assist?

ie

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Interior.Color <> RGB (255, 0, 0) Then


Dim xDateSelected As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String


On Error Resume Next


Application.ScreenUpdating = False
Application.DisplayAlerts = False


' Set this to the exact color or flip the statement so it's:

' If Target.Interior.Color <> RGB(255, 0, 0) Then

Dim r As Integer
Dim c As Integer
Dim staff As String
Dim date1 As String

r = 0
c = 0

While Target.Offset(r, 0) <> ""
r = r - 1

Wend

While Target.Offset(0, c) <> ""
c = c - 1

Wend

'These move through the row (and then the column) until a non empty cell is found

staff = Target.Offset(0, c).Value
date1 = Target.Offset(r, 0).Value & Target.Offset(r - 2, 0).Value

'Get the string values; need to append the two day then date values

Set xDateSelected = Range("date1").Value
Set Mydate = Intersect(Target, xDateSelected)
ActiveWorkbook.Save


If Not Mydate Is Nothing Then

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

'code to retrieve content from affected cells and putting into email content ie "staff name" is applying for leave on "date"

xMailBody = "Hi there Priscilla" & vbNewLine & vbNewLine & _
"Name: " & Range("A" & Target.Row).Value & " is applying for Ad-hoc leave on " & Range("date1" & Target.Row).Value & vbNewLine & vbNewLine & _
"Reason: " & vbNewLine & vbNewLine & _
"Thank you" & vbNewLine 'calling out and placing values of each col into email body

'code to create email content



With xMailItem
.To = "foong.jia.yi1@nhcs.com.sg"
.Subject = "Applying for Ad-hoc leave "
.Body = xMailBody
.Attachments.Add (ThisWorkbook.FullName)
.Display

End With

Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing

End If


Application.DisplayAlerts = True

Application.ScreenUpdating = True


End If


End Sub