Creer une alerte sur Excel

Version imprimable

03/06/2014, 11h14
chartier

Creer une alerte sur Excel

Bonjour ,
Je voudrais créer une application sur Excel qui va me permettre de gérer la date d'expiration de certains document avec une alerte soit visuel ou par mail
j'aimerais renseigner le tableau comme suit :
-NOM ET PRÉNOM
- DATE DE NAISSANCE
FONCTION
NUMÉRO DU LIVRET
DATE DE DÉLIVRANCE DU LIVRET
DATE D'EXPIRATION
DATE DE DÉLIVRANCE DU PASSEPORT
DATE D'EXPIRATION
DATE DE VISITE MÉDICAL
DATE D'EXPIRATION

NB : J'aimerais avoir une alerte soit visiel ou par mail a chaque fois que le Livret - Le passport et la visite medical arrive a une date d'expiration
03/06/2014, 11h34
Daniel.C

Bonjour,

Avec des dates d'expiration en colonnes F, H et J, Sélectionne les 3 colonnes, fais une mise en forme conditionnelle avec la formule :

Code:

=F1>=AUJOURDHUI()-10

Le "-10" signifie que l'alerte apparaîtra 10 jours avant la date d'expiration. A paramétrer. Si tu veux une alerte par mail, précise ton logiciel de messagerie.
03/06/2014, 11h39
chartier

Mon logiciel de messagerie est outlook...
03/06/2014, 18h47
Daniel.C

C'est toujours important de préciser sa version d'Excel. Maintenant, est-ce que tu veux un message par alerte ou un message par jour ou ? Et qu'est-e que tu veux comme texte dans le message ? avec quelles cellules ? Si possible, mets un classeur exemple - sans données confidentielles en pièce jointe.
04/06/2014, 12h33
chartier

1 pièce(s) jointe(s)

Je précise que je travaille sur outlook 2013 et Excel 2013 et j'aimerais avoir soit a l'ouverture du fichier un message BOX ou par mails via outlook un message qui me prévient 6 mois avant la date d'expiration du passeport et du livret les noms des personnes que je dois renouveler leur passeport ou livrer maritime .Et 3 mois avant pour la visite médicale . Et mettre automatiquement Les cellules observation a jour c'a d valide en vert et a Renouveler en rouge

Bonjour,test ça

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Sub test()
Dim R As Range
Dim L As Long
Dim msg As String
msg = ""
Set R = ActiveSheet.UsedRange
For L = 4 To R.Rows.Count
    If DateValide(R(L, 7), Date, 6) = False Then
        R(L, 8) = "A RENOUVELER"
        msg = msg & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 7), "LIVRET MARITIME")
    End If
    If DateValide(R(L, 10), Date, 6) = False Then
        R(L, 11) = "A RENOUVELER"
        msg = msg & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 10), "PASSPORT")
    End If
    If DateValide(R(L, 15), Date, 3) = False Then
     R(L, 15).Select
        R(L, 16) = "A RENOUVELER"
        msg = msg & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 15), "VISITE MEDICALE")
    End If
Next
 
If Trim("" & msg) <> "" Then
    msg = "<table border='1' cellspacing='0'  width='100%'>" & MessageTitre & msg & "</Table>"
    Mail "Voici", msg, "ton@maiL.com"
End If
End Sub
Function DateValide(Fin As Date, JJ As Date, Intervale As Integer) As Boolean
If DateDiff("m", Fin, JJ) > Intervale Then DateValide = True
End Function
Sub Mail(Sujet As String, Message As String, Destinataire As String)
Set Outlook = CreateObject("Outlook.application")
Set MailObj = Outlook.CreateItem(olMailItem)
With MailObj
  .To = Destinataire
   .Subject = Sujet
  .BodyFormat = 2
  .HTMLBody = Message
  '.Display 'Can be .Send but prompts for user intervention before sending without 3rd party software like ClickYes
 .Send
End With
 
End Sub
Function Message(NOM As String, PRENOM As String, FONCTION As String, DATE_EXPIRATION As Date, TypeDoc As String) As String
Message = "<TR>"
Message = Message & "<TD>Le: " & TypeDoc & "</TD>"
Message = Message & "<TD> De: " & NOM & " " & PRENOM & "</TD>"
Message = Message & "<TD>Occupent la fonction de: " & FONCTION & "</TD>"
Message = Message & "<TD>Expire-le : " & DATE_EXPIRATION & "</TD>"
Message = Message & "</TR>" & vbCrLf
End Function
Function MessageTitre() As String
MessageTitre = "<TR>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>&nbspType de document</TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>&nbsp NOM PRENOM </TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>&nbsp FONCTION </TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>&nbsp DATE EXPIRATION </TD>"
MessageTitre = MessageTitre & "</TR>" & vbCrLf
End Function

04/06/2014, 15h23
chartier

Merci pour le code super ça marche . Mais j'aimerais que vous apporter une modification sur les points suivants
-J'aimerais qu'il m'envoie par mails 6 mois avant la date d'expiration du livret et du passeport et 4 mois avant la date d'expiration pour la visite médicale le noms des personnes uniquement dont les livret,passeport et visite médicale vont être expirer . Je voudrai être prévenu par mails 6 mois avant la date d'expiration pour le passeport et livret et 4 mois pour la visite médicale et si possible les faits clignoté en rouge ou les mettre en rouge automatiquement dans les cellules observations . d’où on aura valide en vert et a renouveler en rouge .Merci d'avance

pour le rouge, une mise en forme conditionnelle sur la colonne suffit.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Sub test()
Dim R As Range
Dim L As Long
Dim msgLIVRET As String
Dim msgPASSPORT As String
Dim msgVISITE As String
msgLIVRET = ""
msgPASSPORT = ""
msgVISITE = ""
Set R = ActiveSheet.UsedRange
For L = 4 To R.Rows.Count
    If DateValide(R(L, 7), Date, 6) = False Then
        R(L, 8) = "A RENOUVELER"
        msgLIVRET = msgLIVRET & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 7), "LIVRET MARITIME")
    End If
    If DateValide(R(L, 10), Date, 6) = False Then
        R(L, 11) = "A RENOUVELER"
        msgmsgPASSPORT = msgmsgPASSPORT & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 10), "PASSPORT")
    End If
    If DateValide(R(L, 15), Date, 3) = False Then
     R(L, 15).Select
        R(L, 16) = "A RENOUVELER"
        msgVISITE = msgVISITE & Message(R(L, 2), R(L, 3), R(L, 5), R(L, 15), "VISITE MEDICALE")
    End If
Next
 
If Trim("" & msgLIVRET) <> "" Then
    msgLIVRET = "<table border='1' cellspacing='0'  width='100%'>" & MessageTitre & msgLIVRET & "</Table>"
    Mail "LIVRET MARITIME", msgLIVRET, "ton@maiL.com"
End If
If Trim("" & msgPASSPORT) <> "" Then
    msgPASSPORT = "<table border='1' cellspacing='0'  width='100%'>" & MessageTitre & msgPASSPORT & "</Table>"
    Mail "PASSPORT", msgPASSPORT, "ton@maiL.com"
End If
 
If Trim("" & msgVISITE) <> "" Then
    msgVISITE = "<table border='1' cellspacing='0'  width='100%'>" & MessageTitre & msgVISITE & "</Table>"
    Mail ""VISITE MEDICALE", msgVISITE, "ton@maiL.com"
End If
 
 
End Sub
Function DateValide(Fin As Date, JJ As Date, Intervale As Integer) As Boolean
If DateDiff("m", Fin, JJ) > Intervale Then DateValide = True
End Function
Sub Mail(Sujet As String, Message As String, Destinataire As String)
Set Outlook = CreateObject("Outlook.application")
Set MailObj = Outlook.CreateItem(olMailItem)
With MailObj
  .To = Destinataire
   .Subject = Sujet
  .BodyFormat = 2
  .HTMLBody = Message
  '.Display 'Can be .Send but prompts for user intervention before sending without 3rd party software like ClickYes
 .Send
End With
 
End Sub
Function Message(NOM As String, PRENOM As String, FONCTION As String, DATE_EXPIRATION As Date, TypeDoc As String) As String
Message = "<TR>"
'Message = Message & "<TD>Le: " & TypeDoc & "</TD>"
Message = Message & "<TD> De: " & NOM & " " & PRENOM & "</TD>"
'Message = Message & "<TD>Occupent la fonction de: " & FONCTION & "</TD>"
Message = Message & "<TD>Expire-le : " & DATE_EXPIRATION & "</TD>"
Message = Message & "</TR>" & vbCrLf
End Function
Function MessageTitre() As String
MessageTitre = "<TR>"
'MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>Type de document</TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'> NOM PRENOM </TD>"
'MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'>FONCTION </TD>"
MessageTitre = MessageTitre & "<TD bgcolor='#aaaaaa'> DATE EXPIRATION </TD>"
MessageTitre = MessageTitre & "</TR>" & vbCrLf
End Function