Test présence RDV outlook

Signaler
-
Bonjour,
J'ai parcouru divers forums et tenter de faire une maccro me permettant de planifier à une date renseignée sur Excel un RDV Outlook. Jusque là tout va bien... Quand le RDV est créé, la colonne C s'incrémente d'un texte "OUI". J'ai une boucle qui permet de vérifier si la colonne C est "OUI" alors la macro ne créé rien. Or, la date peut changer (il s'agit de visite médicale où une fois passée, une nouvelle date viendra la remplacer pour la prochaine visite à venir) et auquel cas, il faut que la personne qui gérera le fichier modifie la date et enlève le "OUI". Ce qui n'est pas assez fiable. Peut-on demander à Excel de tester s'il y a un RDV déjà existant pour un nom de sujet (le sujet est "calculé" dans la maccro) et à une date donnée (celle en colonne B)? Si oui, comment?

Voici le module en place :
Sub AjoutRV()
  Dim DLig As Long, Lig As Long
  Dim OutObj As Outlook.Application
  Dim OutAppt As Outlook.AppointmentItem
  Dim DateRdv As Date, FlgRdv As Boolean

  ' Créer une instance d'Outlook
  Set OutObj = CreateObject("outlook.application")
  ' Avec la feuille
  With Sheets("Suivi")
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne
    For Lig = 2 To DLig
      ' Si une date de relance existe
      If .Range("B" & Lig) <> "" Then
        ' Si un RDV n'a pas déjà été créé
        If .Range("C" & Lig) <> "Oui" Then
           FlgRdv = True
          Else
          ' Sinon, pas de RDV déjà créé
          FlgRdv = False
        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("B" & Lig)
        Set OutAppt = OutObj.CreateItem(olAppointmentItem)
        With OutAppt
          .Subject = "Visite Médicale " & Sheets("Suivi").Range("A" & Lig)
          .Start = DateRdv & " 08:00"
          .Duration = 60
          .ReminderSet = True
          .Save
        End With
        ' Créer le commentaire et inscrire Oui
        On Error Resume Next
        .Range("C" & Lig) = "Oui"
        On Error GoTo 0
      End If
    Next Lig
  End With
  Set OutAppt = Nothing
End Sub

Je vous remercie par avance pour votre aide.
Bonne journée,
Audrey

EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ICI

Merci d'y penser dans tes prochains messages.