Rappel Outlook à partir d'Excel

re,

voici la dernière version,

Sub AjoutRV()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Library"
Dim sh As Worksheet, Durée As String, début As String
Dim Lig As Long, DateRdv As Date, sSubject As String, sStart As String, iDuration As Integer,  iRappel As Integer
Dim OutObj As Object, OutAppt As Object
Dim sFilter As String
Dim oAppointment As Outlook.AppointmentItem
Dim namespaceOutlook As Outlook.Namespace
Dim DossierCalendrier As Outlook.MAPIFolder

Set OutObj = CreateObject("outlook.application")
Set namespaceOutlook = OutObj.GetNamespace("MAPI")

Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar)
Set sh = Sheets("A faire")

If ActiveCell.Row < 5 Then GoTo fin
If Cells(ActiveCell.Row, "B") = "" Then GoTo fin
If Cells(ActiveCell.Row, "G") = "" Then GoTo fin

'Durée du RDV
Durée = InputBox("Saisir la durée du RDV ou de la tache (nombre entier)")
    If Durée = "" Then
    iDuration = 10
    Else
    iDuration = Durée * 1
    End If

'Heure du Rdv
début = InputBox("Saisir l'heure du RDV ou de la tache (format hh:mm) : ")

'Rappel
Rappel = InputBox("Saisir le nombre de jour avant le RDV ou de la tache pour avoir le rappel : ")
    If Rappel = "" Then
        iRappel = 60
    Else
        iRappel = Rappel * 1440
    End If

With sh
    Lig = ActiveCell.Row
    DateRdv = Range("G" & Lig)

    sSubject = sh.Range("B" & Lig) & " " & sh.Range("C" & Lig)
    sStart = DateRdv & " " & début

    Set OutAppt = OutObj.CreateItem(1)
    sFilter = "[Subject] = '" & sSubject & "' "
    Set oAppointment = DossierCalendrier.Items.Find(sFilter)

    If Not oAppointment Is Nothing Then
        With oAppointment
        .Subject = sSubject
        .Start = sStart
        .Duration = iDuration
        .ReminderMinutesBeforeStart = iRappel
        .Save
        End With
    Else
        With OutAppt
        .Subject = sSubject
        .Start = sStart
        .Duration = iDuration
        .ReminderMinutesBeforeStart = iRappel
        .Save
        End With
    End If

        ' Créer le commentaire et inscrire Oui
        On Error Resume Next
        .Range("D" & Lig).Comment.Delete
        .Range("D" & Lig).AddComment Text:=.Range("D" & Lig).Value
        .Range("D" & Lig) = "Oui"
        On Error GoTo 0
End With

Set OutAppt = Nothing
MsgBox "Le rappel a été crée"
Exit Sub
fin:
MsgBox "Le rappel n'a pas été crée"
End Sub

Merci beaucoup,

T'es au top

Bon week end à toi !!

Bonjour,

Novice complet, je viens d'utiliser ce code pour un tableau. Le code marche parfaitement.

Mais dans mon tableau j'ai 2 informations à vérifier, à deux dates différentes.

Je ne sais pas comment doubler le code?

Si quelqu'un peut m'aider?

Merci

Dim Lig As Long
Dim OutObj As Object, OutAppt As Object
Dim DateRdv As Date, FlgRdv As Boolean
Dim sFilter As String
Dim oAppointment As Outlook.AppointmentItem

Dim namespaceOutlook As Outlook.Namespace
Dim DossierCalendrier As Outlook.MAPIFolder

  ' Créer une instance d'Outlook
 Set OutObj = CreateObject("outlook.application")
 Set namespaceOutlook = OutObj.GetNamespace("MAPI")

 Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar)
  ' Avec la feuille
 With Sheets("Suivi")
    Lig = ActiveCell.Row
      ' Si une date de relance existe
     If .Range("B" & Lig) <> "" Then
        ' Si un RDV n'a pas déjà été créé
       If .Range("S" & Lig) <> "" Then
          ' Si le commentaire à changé
         If .Range("S" & Lig).Comment.Text <> .Range("E" & Lig).Value Then
            FlgRdv = True
          Else
            ' Sinon le commentaire n'a pas changé = pas de RDV
           FlgRdv = False
          End If
        Else
          ' Sinon, pas de RDV déjà créé
         FlgRdv = True
        End If
      Else
        ' Sinon, pas de date de relance
       FlgRdv = False
      End If
      ' Si le FLAG est à vrai on créé le RDV
     If FlgRdv Then
        DateRdv = Range("R" & Lig)
        Set OutAppt = OutObj.CreateItem(1)
        sFilter = "[Subject] = 'Rappeler " & Sheets("Suivi").Range("B" & Lig) & " au " & Sheets("Suivi").Range("E" & Lig) & "' "
        Set oAppointment = DossierCalendrier.Items.Find(sFilter)

        If Not oAppointment Is Nothing Then
            With oAppointment
                .Subject = "Rappeler " & Sheets("Suivi").Range("B" & Lig) & " au " & Sheets("Suivi").Range("E" & Lig)
                .Start = DateRdv & " 08:00"
                .Duration = 60
                .ReminderSet = True
                .Save
            End With
        Else
            With OutAppt
              .Subject = "Rappeler " & Sheets("Suivi").Range("B" & Lig) & " au " & Sheets("Suivi").Range("E" & Lig)
              .Start = DateRdv & " 08:00"
              .Duration = 60
              .ReminderSet = True
              .Save
            End With
        End If

        ' Créer le commentaire et inscrire Oui
       On Error Resume Next
        .Range("S" & Lig).Comment.Delete
        .Range("S" & Lig).AddComment Text:=.Range("C" & Lig).Value
        .Range("S" & Lig) = "Oui"
        On Error GoTo 0
      End If

  End With
  Set OutAppt = Nothing