duree = Now - NoLigfaire :
duree = Now - Var.
Dim Var As Date Dim Exi As Date '.... For NoLig = 6 to 200 NoCol = 7 'lecture de la colonne G Var = Worksheets("Feuil4").Cells(NoLig, NoCol).Value NoCol = 24 'lecture de la colonne X Exi = Worksheets("Feuil4").Cells(NoLig, NoCol).Value '.... .HTMLBody = "Bonjour,<br>" & _ "<br>" & _ "Le plan d'action <B>doit être révisé</B>, pensez à changer les dates.<br>" & _ "Il a expiré le " & Exi & ".<br>" & _ "<br>" & _ "Cordialement."
Sub auto_open()
Dim OutApp
Dim OutMail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim duree As Date
Dim NoCol As Integer
Dim NoLig As Long, Var As Date
Dim Exi As Date
Dim LValue As Date
LValue = Aujourdhui
'............................
For NoLig = 6 To 119
NoCol = 7 'lecture de la colonne G
Var = Cells(NoLig, NoCol).Value
Exi = Cells(NoLig, NoCol).Value
duree = LValue - Var
If duree > 0 Then
'.............................;
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Plan d'action - Révision nécessaire"
.HTMLBody = "Bonjour,<br><br>" & "Le plan d'action <B> </B>doit être révisée, " & "Il a expiré le " & Exi & "pensez à changer les dates.<br><br>" & "Cordialement."
.Send
End With
End If
Next
On Error GoTo 0
End Sub
'Note : L'objectif est d'envoyer toutes les cellules de la colonne 1 qui ont une date < à Aujoudhui() sur la cellules parallèle dans la colonne G nommée (Echéance)
Private Sub Workbook_Open() Call EnvoiMailDeRappel End Sub
Sub EnvoiMailDeRappel() Dim OutApp As Object 'Application Outlook Dim OutMail As Object 'Mail Outlook Dim wsh As Worksheet 'feuille contenant les données Dim ech As Variant 'date d'échéance Dim nom As Variant 'nom du plan Dim noL As Long 'numèro de ligne Dim drL As Long 'dernière ligne Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) Set wsh = Worksheets("Feuil4") drL = wsh.Cells(wsh.Rows.Count, "A").End(xlUp).Row For noL = 6 To drL nom = wsh.Cells(noL, "A").Value ech = wsh.Cells(noL, "G").Value If IsDate(ech) Then If ech - Date < 0 Then With OutMail .To = "" .CC = "" .BCC = "" .Subject = "Plan d'action " & nom & " - Révision nécessaire" .HTMLBody = "Bonjour,<br>" & _ "<br>" & _ "Le plan d'action <B>" & nom & " a expiré le " & ech & "</B><br>" & _ "<br>" & _ "Il doit être révisé. Pensez à changer les dates.<br>" & _ "<br>" & _ "Cordialement." .Send End With End If End If Next noL End Sub
Sub EnvoiMailDeRappel() Dim OutApp As Object 'Application Outlook Dim OutMail As Object 'Mail Outlook Dim wsh As Worksheet 'feuille contenant les données Dim ech As Variant 'date d'échéance Dim nom As Variant 'nom du plan Dim noL As Long 'numèro de ligne Dim drL As Long 'dernière ligne Set OutApp = CreateObject("Outlook.Application") Set wsh = Worksheets("Feuil4") drL = wsh.Cells(wsh.Rows.Count, "A").End(xlUp).Row For noL = 6 To drL nom = wsh.Cells(noL, "A").Value ech = wsh.Cells(noL, "G").Value If IsDate(ech) Then If ech - Date < 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = "" .CC = "" .BCC = "" .Subject = "Plan d'action " & nom & " - Révision nécessaire" .HTMLBody = "Bonjour,<br>" & _ "<br>" & _ "Le plan d'action <B>" & nom & " a expiré le " & ech & "</B><br>" & _ "<br>" & _ "Il doit être révisé. Pensez à changer les dates.<br>" & _ "<br>" & _ "Cordialement." .Send End With Set OutMail = Nothing End If End If Next noL End Sub
Sub Macro2() '''''instructions ActiveWorkbook.Save ' enregistre ActiveWorkbook.Close False 'ferme End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionSub EnvoiMailDeRappel() Dim OutApp As Object 'Application Outlook Dim OutMail As Object 'Mail Outlook Dim d As Object 'Dictionaire des SWOT Dim clé As Variant 'Clé du dictionaire Dim wsh As Worksheet 'feuille contenant les données Dim ech As Variant 'date d'échéance Dim sco As Variant 'Score d'avancement Dim SWOT As Variant 'Lien avec la matrice SWOT Dim nom As Variant 'nom du plan Dim noL As Long 'numèro de ligne Dim drL As Long 'dernière ligne Set OutApp = CreateObject("Outlook.Application") Set d = CreateObject("Scripting.Dictionary") Set wsh = ThisWorkbook.Worksheets("PA") drL = wsh.Cells(wsh.Rows.Count, "B").End(xlUp).Row + 4 'Pourquoi + 4 ????? For noL = 6 To drL nom = wsh.Cells(noL, "C").Value SWOT = wsh.Cells(noL, "B").Value ech = wsh.Cells(noL, "H").Value sco = wsh.Cells(noL, "J").Value If IsDate(ech) Then If ech - Date < 0 Then If sco <> 100 Then If Not d.Exists(SWOT) Then d(SWOT) = "<B>" & SWOT & "==>" & nom & " a expiré le " & ech & "</B><br>" Else d(SWOT) = d(SWOT) & "<B>" & SWOT & "==>" & nom & " a expiré le " & ech & "</B><br>" End If End If End If End If Next noL For Each clé In d.Keys Set OutMail = OutApp.CreateItem(0) With OutMail .To = "" .CC = "" .BCC = "" .Subject = "Plan d'action - Révision nécessaire" .HTMLBody = "Bonjour,<br>" & _ "<br>" & _ "La date d'échéance de : <br>" & _ d(clé) & _ "<br>" & _ clé & " doit être révisé. Pensez à changer les dates.<br>" & _ "<br>" & "Cordialement." .Send End With Next clé End Sub
30 juil. 2018 à 16:40
30 juil. 2018 à 17:12
Sub Alerte()
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim duree As Date
Dim Lig_Deb As Integer 'ligne de début, de fin
Dim NoCol As Integer
Dim NoLig As Long, Var As Variant
Lig_Deb = 6
NoCol = 7 'lecture de la colonne 1
For NoLig = 6 To Split(Feuil4.UsedRange.Address, "$")(4)
Var = Feuil4.Cells(NoLig, NoCol)
duree = Now - Var
If duree > 0 / 0 / 0 Then
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Plan d'action - Révision nécessaire"
.HTMLBody = "Bonjour,<br><br>" & "Le plan d'action <B> </B>doit être révisée, pensez à changer les dates.<br><br>" & "Cordialement."
.Send
End With
End If
Next
On Error Resume Next
On Error GoTo 0
End Sub
==> j'ai l'erreur suivante :