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

M

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
Phil69970
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"...
Trier par date Trier par votes
Phil69970

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
 
Vote positif 0 Vote négatif
Solution
M

mathieu20

XLDnaute Nouveau
Phil69970 à dit:
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
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
M

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)
 
Vote positif 0 Vote négatif
M

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"
 
Vote positif 0 Vote négatif
Phil69970

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
Cliquez pour agrandir...

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

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
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif

Discussions similaires

Chaton0408
  • Question
Microsoft 365 VBA Création Question liste destinataire
Réponses
6
Affichages
344
youky(BJ)
youky(BJ)
M
  • Résolu(e)
XL 2016 envoi de mail en automatique en fonction de plusieurs menus deroulants
2
Réponses
26
Affichages
1 K
mathieu20
M
R3n0W
  • Résolu(e)
XL 2016 If Not xRgSel Is Nothing Then --> Ne marche pas
Réponses
10
Affichages
377
R3n0W
R3n0W
halecs93
  • Question
Microsoft 365 Générer mail via Excel
Réponses
2
Affichages
574
halecs93
halecs93
N
  • Question
Microsoft 365 Code VBA
Réponses
7
Affichages
508
TooFatBoy
TooFatBoy
N
  • Question
XL 2016 Code VBA pour envoi de mail avec pdf en piece jointe
Réponses
4
Affichages
203
Phil69970
Phil69970
M
  • Question
XL 2013 Envoyer un mail automatique avec le contenu de la bonne ligne
Réponses
2
Affichages
773
Oneida
Oneida
J
  • Question
XL 2016 envoie mail automatique lors de double-clic sur cellule
Réponses
6
Affichages
514
J@ba
J
Jojo973
  • Question
Microsoft 365 Trouver et attribuer une plage de cellule en fonction de la cellule active
Réponses
6
Affichages
343
Jojo973
Jojo973
T
  • Résolu(e)
Microsoft 365 Insérer une image DANS une cellule
Réponses
12
Affichages
492
Thomi
T

Membres actuellement en ligne

17 membres et 316 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh