XL 2016 envoi de mail en automatique en fonction de plusieurs menus deroulants

Bonjour,

Je souhaiterais modifier le code ci dessous afin de pouvoir

envoyer un mail en automatique au personnes concernées lorsque les initiales sont renseignées en colonne J, M, P, U

Recevoir une reponse lorsque le sujet est traité pour chaque etape lorsque les colonnes K, N, Q, V sont renseignées avec en destinataire la personne dont les initiales figure en colonne J

Est ce possible d ouvrir un fichier lorsque la colonne G pas a "OUI" ?

Merci


Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range
Dim xOutApp As Object, xMailItem As Object
Dim xMailBody$, Derlig&, Var_A_qui$, Var_Objet$

On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Derlig = Range("M" & Rows.Count).End(xlUp).Row

Set xRg = Range("M3:M" & Derlig)
Set xRgSel = Intersect(Target, xRg)



Var_Objet = Range("A" & xRgSel.Row).Value

' liste des variables pour les adresses mails
Select Case xRgSel.Value
Case "HCH"
Var_A_qui = "HCH@Yahoo.com"
Case "HSE"
Var_A_qui = "HSE@Yahoo.com"
Case "ICE"
Var_A_qui = "ICE@Yahoo.com"
Case "EVI"
Var_A_qui = "EVI@Yahoo.com"
Case "LCA"
Var_A_qui = "LCA@Yahoo.com"
Case "JDE"
Var_A_qui = "JDE@Yahoo.com"
Case "CMA"
Var_A_qui = "CMA@Yahoo.com"
Case "MDU"
Var_A_qui = "MDU@Yahoo.com"
Case "PHC"
Var_A_qui = "PHC@Yahoo.com"
Case "EVA"
Var_A_qui = "EVA@Yahoo.com"
Case "CBE"
Var_A_qui = "CBE@Yahoo.com"


Case Else
MsgBox "Pas trouvé le bon destinataire": Exit Sub 'Facultatif si aucune adresse mail trouvée
End Select

ActiveWorkbook.Save
If Not xRgSel Is Nothing Then
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
'texte dans le corp du message
xMailBody = "Merci de créer la FIA, la cellule " & xRgSel.Address(False, False) & " a été renseignée le " & _
Format$(Now, "mm/dd/yyyy") & " at " & Format$(Now, "hh:mm:ss") & " par " & Environ$("username") & "."

With xMailItem
.To = Var_A_qui '"adresse mail en fonction de la variable"
.Subject = Var_Objet & " Action a effectuer " 'remonte la valeur dans la cellule A & " Action a effectuer "
.body = xMailBody
.Display
End With
End If

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

Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub