XL 2016 mail en automatique dans excel destinataire en fonction de la valeur d une cellule

mathieu20

XLDnaute Nouveau
Bonjour

je souhaiterais envoyer un mail en automatique lorsque une cellule est modifiée dans une colonne

Jusqu a la mon code fonctionne mais je voudrais que l adresse mail puisse varier en fonction du contenu de la cellule et la je bloque

exemple si la cellule

=a envoyer le mail a a@yahoo.fr
=b envoyer le mail a b@yahoo.fr
=c envoyer le mail a c@yahoo.fr

La deuxieme chose que j aimerais pouvoir modifier et l objet du mail qui devrait corresondre a ce qui se trouve en colonne "A" pour la ligne concernée

Avez vous une solution a me proposer

en vous remerciant

Voici le code actuel

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2017/9/12
Dim xRgSel 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 xRg = Range("M3:M10000")
Set xRgSel = Intersect(Target, xRg)


ActiveWorkbook.Save
If Not xRgSel Is Nothing Then
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
xMailBody = "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 = "a@yahoo.com"
.Subject = Range("A3") & " Action a effectuer "
.Body = xMailBody
.Display
End With
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Solution
Bonjour @mathieu20

Je te propose cette solution non testée mais qui devrait fonctionner

VB:
Private Sub Worksheet_Change(ByVal Target As Range) 'Updated by Extendoffice 2017/9/12
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

Select Case xRgSel.Value
Case "a"
    Var_A_qui = "a@yahoo.fr"
Case "b"
    Var_A_qui = "b@yahoo.fr"
Case "c"
    Var_A_qui = "c@yahoo.fr"
Case Else
    MsgBox "Pas trouvé le bon destinataire"...

Phil69970

XLDnaute Barbatruc
Bonjour @mathieu20

Je te propose cette solution non testée mais qui devrait fonctionner

VB:
Private Sub Worksheet_Change(ByVal Target As Range) 'Updated by Extendoffice 2017/9/12
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

Select Case xRgSel.Value
Case "a"
    Var_A_qui = "a@yahoo.fr"
Case "b"
    Var_A_qui = "b@yahoo.fr"
Case "c"
    Var_A_qui = "c@yahoo.fr"
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)
    xMailBody = "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 '"a@yahoo.com"
        .Subject = Var_Objet & " Action a effectuer " 'Range("A3") & " 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

Merci de ton retour

@Phil69970
 

mathieu20

XLDnaute Nouveau
Bonjour @mathieu20

Je te propose cette solution non testée mais qui devrait fonctionner

VB:
Private Sub Worksheet_Change(ByVal Target As Range) 'Updated by Extendoffice 2017/9/12
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

Select Case xRgSel.Value
Case "a"
    Var_A_qui = "a@yahoo.fr"
Case "b"
    Var_A_qui = "b@yahoo.fr"
Case "c"
    Var_A_qui = "c@yahoo.fr"
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)
    xMailBody = "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 '"a@yahoo.com"
        .Subject = Var_Objet & " Action a effectuer " 'Range("A3") & " 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

Merci de ton retour

@Phil69970
 

mathieu20

XLDnaute Nouveau
Une derniere question, si je veux que ce code s applique a d autres colonnes, je dois recopier entierement le code ou je peux juste copier a partir de :

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

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

mathieu20

XLDnaute Nouveau
Le fichier en question sert a suivre les projets, il y a 4 ou 5 intervenants consecutifs sur une meme ligne

Le but est d envoyer un mail a la bonne personne via un menu deroulant en "M", d avoir un retour de mail lorsqu elle renseigne la case "N"

j aurais la meme chose sur les cases "O", "P" et "Q" , "R"
 

Phil69970

XLDnaute Barbatruc
Re

Je te conseille d'ouvrir un autre post comme le demande la charte

1682070134789.png


De plus sans voir le fichier j'ai du mal à te répondre.

En fait toute la 1ere partie de la macro jusqu’à

ActiveWorkbook.Save

permet de choisir :
1) L'objet du mail qui sera choisi
Var_Objet = Range("A" & xRgSel.Row).Value

2) A qui sera envoyé le mail
Select Case xRgSel.Value
Case "a"
Var_A_qui = "a@yahoo.fr"
Case "b"
Var_A_qui = "b@yahoo.fr"
Case "c"
Var_A_qui = "c@yahoo.fr"
Case Else
MsgBox "Pas trouvé le bon destinataire": Exit Sub 'Facultatif si aucune adresse mail trouvée
End Select

La 2eme partie est l'envoi du mail avec les bonnes variables

Après on peut dire je l'envoie à X , Y et Z mais pas sans fichier.

@Phil69970
 

Discussions similaires