Suppression RDC Outlook

Bonjour,

Je te donne une version qui prend le sujet exact généré dans "AjoutRV", qui utilise la bonne ligne active et qui supprime le rappel s'il existe, uniquement si le statut est Approuvé :

 

Sub SupprimerRappelSiApprouve()
    Const olFolderCalendar As Long = 11

    Dim OutObj As Object, OutAppt As Object
    Dim NameSpaceOutlook As Object
    Dim DossierCalendrier As Object
    Dim Lig As Long
    Dim SujetARechercher As String
    Dim DateARechercher As Date
    Dim i As Long

    ' Définir la ligne active
    Lig = ActiveCell.Row

    With ThisWorkbook.Sheets("Registre")
        ' Vérifier que le statut est "approuvé"
        If LCase(Trim(.Range("K" & Lig).Value)) <> "approuvé" Then
            MsgBox "Le statut n'est pas 'approuvé'.", vbExclamation
            Exit Sub
        End If

        ' Construire le sujet comme dans AjoutRV
        SujetARechercher = .Range("K3").Value & "-Relance" & "-DT-GOMTDX-00" & .Range("E" & Lig).Value
        DateARechercher = .Range("Q" & Lig).Value
    End With

    ' Accès à Outlook
    Set OutObj = CreateObject("outlook.application")
    Set NameSpaceOutlook = OutObj.GetNamespace("MAPI")
    Set DossierCalendrier = NameSpaceOutlook.GetDefaultFolder(olFolderCalendar)

    ' Rechercher et supprimer le RDV
    For i = DossierCalendrier.Items.Count To 1 Step -1
        Set OutAppt = DossierCalendrier.Items(i)
        If LCase(Trim(OutAppt.Subject)) = LCase(Trim(SujetARechercher)) _
            And DateValue(OutAppt.Start) = DateValue(DateARechercher) Then
            OutAppt.Delete
            MsgBox "Rappel supprimé pour le sujet : " & SujetARechercher, vbInformation
            Exit Sub
        End If
    Next i

    MsgBox "Aucun rappel trouvé à supprimer.", vbExclamation

    ' Nettoyage
    Set OutAppt = Nothing
    Set DossierCalendrier = Nothing
    Set NameSpaceOutlook = Nothing
    Set OutObj = Nothing
End Sub

Dit moi si tu veux que le rappel soit supprimé automatiquement dès que tu tapes Approuvé dans la cellule K.