Envoyer des mails automatiquement aux personnes concernées
Bonjour
J'ai un fichier excel qui recense des évaluations de poste.
De la colonne A à G, se trouve des informations sur le poste concerné et également la personne à qui envoyé le mail (colonne C). Et en colonne L, il s'agit de la validité de la cotation (OK ou NOK).
Et l'objectif est que pour les cellules NOK, il faudrait envoyer un mail à la personne (nom qui se trouve sur la même ligne) pour lui rappeler de faire l'évaluation.
Il faudrait également que je sache si le mail a été envoyé ou non pour ne part les harceler.
Bonjour,
n'oublier pas d'activer la référence à Microsoft Outlook xx Object Library
Private Sub Testmailauto()
Dim i As Integer, LastRw As Integer, sh1
Set sh1 = Sheets("Fiche Evaluation")
LastRw = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 10 To LastRw
If sh1.Range("L" & i).Value = "NOK" Then
sh1.Range("K" & i) = sh1.Range("K" & i) + 1
sh1.Range("L" & i) = "OK"
envoimail1 sh1.Range("C" & i), sh1.Range("E" & i)
End If
Next i
Set sh1 = Nothing
End Sub
Sub envoimail1(Mailto, poste)
Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Set appOutlook = CreateObject("Outlook.Application")
If Not (appOutlook Is Nothing) Then
Set oMail = appOutlook.CreateItem(olMailItem)
With oMail
.To = Mailto
.Subject = "Rappel cotation FSSE " & Mailto
.Body = "Bonjour, Merci de mettre à jour votre cotation FSSE " & poste
.Display
' .Send
End With
Set oMail = Nothing
Set appOutlook = Nothing
End If
End Sub
Bonjour et Merci sabV.
Ton code fonctionne très bien.
Private Sub Testmailauto()
Dim i As Integer, LastRw As Integer, sh1
Set sh1 = Sheets("Fiche Evaluation")
LastRw = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 10 To LastRw
If sh1.Range("L" & i).Value = "NOK" Then
sh1.Range("K" & i) = sh1.Range("K" & i) + 1
sh1.Range("J" & i) = "FAITE"
envoimail1 sh1.Range("C" & i), sh1.Range("E" & i)
End If
Next i
Set sh1 = Nothing
End Sub
Sub envoimail1(Mailto, poste)
Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Set appOutlook = CreateObject("Outlook.Application")
If Not (appOutlook Is Nothing) Then
Set oMail = appOutlook.CreateItem(olMailItem)
With oMail
.To = Mailto
.Subject = "Rappel cotation FSSE " & Mailto
.Body = "Bonjour, Merci de mettre à jour votre cotation FSSE ST/OP N°" & poste
.Display
' .Send
End With
Set oMail = Nothing
Set appOutlook = Nothing
End If
End Sub
J'ai juste fait une modification afin que lorsque le mail est envoyé la colonne L (Validité FSSE) reste NOK car il n'a pas encore fait la mise à jour de la cotation.
J'ai également rajouté dans la colonne J ==> l'état des relances (FAITE).
Pour info pour que les cellules de la colonne L affiche OK il faut que la date de cotation colonne H soit inf à 1an par rapport à la date du jour (=aujourdhui). si c'est pas le cas la cellule affiche NOK.
Est-il possible par contre de remettre à zero les colonnes J et K lorsque le poste a été réévalué (autrement dit lorsqu'il passe de NOK à OK) ?
Merci
Bonjour,
Voilà pour la remise à zero lorsque la colonne L = "OK"
Private Sub Testmailauto2()
Dim i As Integer, LastRw As Integer, sh1
Set sh1 = Sheets("Fiche Evaluation")
LastRw = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 10 To LastRw
If sh1.Range("L" & i).Value = "NOK" Then
sh1.Range("K" & i) = sh1.Range("K" & i) + 1
sh1.Range("J" & i) = "FAITE"
envoimail1 sh1.Range("C" & i), sh1.Range("E" & i)
Else
sh1.Range("K" & i).ClearContents
sh1.Range("J" & i).ClearContents
End If
Next i
Set sh1 = Nothing
End Sub
Merci pour vos réponses ça fonctionne très bien.
Autre problématique, j'ai un tableau au deux colonnes qui s'actualise automatiquement. J'ai besoin d'avoir un suivi de ces chiffres sur la durée.
Donc autrement dit lorsque une valeur change, il faudrait que la valeur se reporte sur le graphique.
Je vous joint mon fichier excel.
Par avance merci