Supprimer un rdv dans outlook avec un critère spécifique

Bonsoir à tous,

Je suis à la recherche d'un code pouvant supprimer un rdv dans Outlook avec comme critère le sujet. voici une vision de mon tableau structuré.

pour le reste je perdu .... à savoir les rdv changent régulièrement je perds un temps fou à les supprimer à la main .

voici le code qui me permet de mettre les rdv dans Outlook, il fonctionne très bien je l 'ai adapter à mon tableau:

Sub rdv_outlook()

'nécéssite d'activer la référence Microsoft Outlook 16.0 Object Library

Dim myolapp As New Outlook.Application
Dim MyItem As Outlook.AppointmentItem
Dim Cell As Range
'départ de la recherche
For Each Cell In Range("B3:B" & Range("B9999").End(xlUp).Row)

'boucle pour valider les rdv
If IsEmpty(Range("J" & Cell.Row)) Then

Set MyItem = myolapp.CreateItem(olAppointmentItem)
With MyItem
.MeetingStatus = olNonMeeting
'TITRE(sujet) du rdv
.Subject = Cell
'adresse (emplacement) du rdv
.Location = Cell.Offset(0, 1)
'COULEUR DANS OUTLOOK CATEGORIE
.Categories = Cell.Offset(0, 3)
'texte du rdv
.Body = Cell.Offset(0, 2)
'date DEBUT+ h de debut rdv
.Start = Cell.Offset(0, 4) + Cell.Offset(0, 5)
'date FIN + h de FIN rdv
'.End = Range("G3") + Range("H3")
.Duration = Cell.Offset(0, 7)
'rappel
.ReminderMinutesBeforeStart = 1440
'afficher la fenetre du rdv
'.Display
'sauvegarde dans outllook
.Save
.Close (olSave)
End With
Range("J" & Cell.Row) = "Les rdv sont bien planifier dans OUTLOOK" 'Au lieu de X on peut mettre n'importe quoi, la date de création du rendez-vous...
End If
Set MyItem = Nothing
Next Cell

MsgBox "Les rdv sont bien planifier dans OUTLOOK", vbExclamation, "CHRISTOPHE VANNIER"
End Sub

Edit modo : merci de mettre le code entre balises SVP avec le bouton </>

Merci à vous pour d'éventuels explications ou sans doute une solution simple.

Hello,

A tester en adaptant le code à ton besoin :

Dim c As Range    'variable objet Range de la cellue en cours de boucle
    'nécéssite d'activer la référence Microsoft Outlook 16.0 Object Library
    Dim OlApp As New Outlook.Application    'déclaraction et création (New) de l'instance Outlook
    Dim OlMapi As Outlook.Namespace
    Dim OlFolder As Outlook.MAPIFolder
    Dim OlAppointment As Outlook.AppointmentItem
    'Initialisation des variables
    Set OlMapi = OlApp.GetNamespace("MAPI")
    Set OlFolder = OlMapi.GetDefaultFolder(olFolderCalendar)

    'Travail sur la feuille 'Calendrier'
    With Sheets("Calendrier")    'mettre le nom de la feuille en remplacement de Feuil1
        'Parcourir les cellules de la colonne A de la ligne 2 à la dernière ligne occupée
        For Each c In .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
            'Si la cellule n'est pas vide
            If c.Text <> "" Then
                'Parcourir les rdv pour voir si le sujet correspond au contenu de la cellule
                For Each OlAppointment In OlFolder.Items
                    'si oui supprimé le rdv
                    If OlAppointment.Subject = c.Text Then OlAppointment.Delete
                Next
            End If
        Next
    End With
    Set OlMapi = Nothing
    Set OlApp = Nothing

Bonsoir,

Comme il s'agit d'un tableau structuré, il faut utiliser le code VBA spécifique à cet objet. Par ailleurs, un filtrage du sujet pour les RDVs dans Outlook sera plus performant. Ci-dessous exemple de code

Sub supp_rdvs()

    Dim TS As ListObject
    Dim i As Integer
    Dim OlApp As New Outlook.Application
    Dim calendrier As Outlook.Folder
    Dim rdvs_trouvés As Outlook.Items
    Dim rdv As Outlook.AppointmentItem
    Dim sujet As String, filtre As String

    '// affectation du tableau structuré
    Set TS = [nom_du_tableau].ListObject

    '//définition application Outlook
    Set OlApp = Outlook.Application

    '// affectation calendrier par défaut
    Set calendrier = OlApp.Session.GetDefaultFolder(olFolderCalendar)

    '// Suppression des RDV présents dans la colonne titre du tableau structuré
    For i = 1 To TS.ListRows.Count

        'recherche des emails envoyés correspondant au sujet
        sujet = TS.ListColumns("titre").DataBodyRange(i)
        filtre = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & sujet & "%'"
        Set rdvs_trouvés = calendrier.Items.Restrict(filtre)

        'suppression des emails trouvés
        For Each rdv In rdvs_trouvés
            rdv.Delete
        Next rdv

    Next i

End Sub

Bonsoir, merci à vous pour ces réponses je vais les essayer👍😊

bonsoir THEV,

cela fonctionne tellement bien, tous les titres de la colonne titre on été effacer !

je souhaite que la colonne RDV à SUPRIMER DANS OUTLLOOK comporte un croix quand je veux que le rdv soit supprimer.

une croix quand le rdv est supprimer dans la colonne L (rdv supprimé)

je peux mettre cela sur la colonne date cela me parait plus facile a gérer pour moi.

merci par avance 👍😊

Bonjour,

D'après ce que je crois comprendre de votre demande, il faudrait juste apporter la modification suivante :

    '// Suppression des RDV présents dans la colonne titre du tableau structuré si supprimés
    For i = 1 To TS.ListRows.Count

        If TS.ListColumns("rdv supprimé").DataBodyRange(i) = "X" Then

            'recherche des emails envoyés correspondant au sujet
            sujet = TS.ListColumns("titre").DataBodyRange(i)
            filtre = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & sujet & "%'"
            Set rdvs_trouvés = calendrier.Items.Restrict(filtre)

            'suppression des emails trouvés
            For Each rdv In rdvs_trouvés
                rdv.Delete
            Next rdv

        End If

    Next i