XL 2010 MACRO - problème création évènement outlook

[AntoineM]

Bonjour,

J'ai créer un code afin de générer automatiquement un mail & une alerte outlook. Cependant, une erreur c'est glissé dans mon code, et je ne parvient pas à l'identifier.

Je reçois bien les mails (par exemple, pour "employé maîtrisant", j'ai bien deux mails, qui correspondent bien à mes 2 personnes) mais il n'y a qu'un évènement de créer. Seulement le dernier évènement est créer. Je ne comprend pas pourquoi

Voici le code : (le fichier est en pièce jointe)

Sub EmplMaitri()
 
    Dim i As Integer
    Dim VarDate As Date
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Chemin As String
    Dim Nom As String
    Dim corps As String
    Dim Prenom As String
    Dim statut As String
    Dim objOutlook As Object
    Dim objOutlookAppt As Object
   
Set objOutlook = CreateObject("Outlook.application")
Set objOutlookAppt = objOutlook.Createitem(1)
 
 
For i = 2 To Range("E" & Rows.Count).End(xlUp).Row
 
VarDate = Range("E" & i).Value
 
If Range("E" & i).Font.Italic = True And Range("E" & i) < DateAdd("m", 1, Now) Then
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
'envoi mail
EDate = Format(Range("E" & i), "dddd d mmmm yyyy")
statut = Range("E1").Value
Nom = Range("A" & i).Value
Prenom = Range("B" & i).Value
corps = "Bonjour," & vbCrLf & vbCrLf & "Pour information, " & Prenom & " " & Nom & " sera éligible pour une re-classification. Il sera éligible à partir du " & EDate & "." & vbCrLf & vbCrLf & "Il pourra prétendre au statut d'" & statut & "." & vbCrLf & vbCrLf & "Bien à toi, "
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.Createitem(0)
 
        With OutMail
            .To = "antoine.muneret@nespresso.com"
            .CC = ""
            .BCC = ""
            .Subject = "Classification " & Prenom & " " & Nom
            .body = corps
            .Send
        End With
       
'création évenement Outlook
        With objOutlookAppt
            .Start = Sheets("Feuil1").Range("E" & i) & " 10:00"
            .Subject = "Entretien de Classification de " & Prenom & " " & Nom
            .body = Prenom & " " & Nom & "est éligible aujourd'hui à une re-classification en vue de devenir " & statut & "."
            .Location = "Boutique Grenoble"
            .AllDayEvent = False
            .ReminderSet = True
            .Categories = "Catégorie Bleue"
            .Save
        End With
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
 
End If
 
Next i
 
End Sub

Bien à vous,

AntoineM

 

[jecherche]

Bonjour,

Le 2e rendez-vous écrase le 1er.
Déplace :

Set objOutlookAppt = objOutlook.CreateItem(1)

Juste avant :

 With objOutlookAppt
  .Start = Sheets("Feuil1").Range("E" & i) & " 10:00"....

Jecherche

 

[AntoineM]

Magnifique.

Effectivement tout fonctionne avec ce déplacement.

Merci