Comment effacer des rendez-vous dans un agenda Outlook à partir d'Excel ?

Bonjour à tous,

Je travaille sur le code d'un document au boulot que je dois améliorer, d'après mon boss ^^

le problème c'est qu'en vba, je sait faire du très basic, mais là il me demande de créer un code à partir de celui-ci qui CREE des rendez-vous dans Outlook :

Sub REUNION_SABLIER()
Dim olApp As Outlook.ApplicationDim olAppItem As Outlook.AppointmentItem
Dim DEBUT, FIN, L&, LR&
Set olApp = CreateObject("Outlook.Application")
With Worksheets("Dashboard")
LR = .Cells(.Rows.Count, 14).End(xlUp).Row
For L = 23 To 194
If .Cells(L, 23) <> "" And .Cells(L, 15) = "" Then
DEBUT = DateValue(.Cells(L, 23)) + .Cells(L, 17)
FIN = DateValue(.Cells(L, 23)) + .Cells(L, 18)
Set olAppItem = olApp.CreateItem(olAppointmentItem)
With olAppItem
.Body = Worksheets("Dashboard").Cells(L, 21)
.ReminderSet = True
.BusyStatus = olFree
.Start = DEBUT
.End = FIN
.Subject = Worksheets("Dashboard").Cells(L, 19)
.Save
End With
.Cells(L, 15) = "RDV créé"
End If
Next L
End With
Set olAppItem = Nothing
Set olApp = Nothing
End Sub

Il me demande de faire un code à partir de celui-ci qui effacerait les rendez-vous qui ont été créé par ce code

Les rendez-vous créé par ce code on une cellule "RDV Créé" . L'idée serait que quand il y a rendez-vous créé, on puisse les effacer dans outlook quand on sélectionne "Nettoyer les alertes" dans le menu déroulant en N1.

j'ai trouvé des posts sur le forum qui semblent a peu près correspondre mais quand je teste les lignes ses mettent en jaune et je ne saurais le résoudre.

Je continue à chercher de mon côté , j'ai bientôt plus de cheveux !

Merci pour votre aide,

Luc

Hello ;)

tu peux t'inspirer de ce code-ci :

https://forum.excel-pratique.com/excel/creation-suppression-de-rdv-outlook-via-excel-118666

Par contre je ne saurai pas te dire comment supprimer les rendez-vous en fonction de ta colonne RDV Créé...

Bon courage !

merci pour votre réponse.

Malheuresuement, je n'arriverai pas à l'adapter.

d'ailleurs comment faire pour dire au fichier d'aller rechercher dans outlook les rendez-vous créé ?

Je ne saurai pas te dire, peut-être quelqu'un va t'aider ... Désolé!

Bon courage ;)

Bonsoir,

Avant tout, il faudrait définir vos critères de suppression des RDV (Dates, Sujet, ...) pour cibler la recherche.

Bonjour,

merci pour votre retour,

savez-vous comment faire ?

Je suppose que je doit cibler les même éléments qui m'ont permis à créer le rendez-vous ? Genre ça :

LR = .Cells(.Rows.Count, 14).End(xlUp).Row
For L = 23 To 194
If .Cells(L, 23) <> "" And .Cells(L, 15) = "" Then
DEBUT = DateValue(.Cells(L, 23)) + .Cells(L, 17)
FIN = DateValue(.Cells(L, 23)) + .Cells(L, 18)
Set olAppItem = olApp.CreateItem(olAppointmentItem)
With olAppItem
.Body = Worksheets("Dashboard").Cells(L, 21)

et ça ?

.Body = Worksheets("Dashboard").Cells(L, 21)

et cette ligne ?

.Cells(L, 15) = "RDV créé"

Si oui , comment faire svp ?

Je suppose que je doit cibler les même éléments qui m'ont permis à créer le rendez-vous ?
Certes, mais vous ne précisez pas ces éléments. Un RDV comporte un sujet, une date de début, une date de fin et un emplacement.
Que voulez-vous faire : effacer un RDV ou plusieurs et encore une fois à partir de quels éléments du RDV ?

merci pour votre retour !

en fait il faut supprimer tous les rendez-vous qui ont été créé grace au code decrit dans le 1er post.

Tous les critères sont donc les même que ceux utilisés pour la creation.

Tous les rendez-vous qui ont été créé doivent être supprimés, sans distinction.

dans les faits, voici comment sa se passe : quand on utilise le fichier, c'est pour des dossiers sur lesquels on ne doit pas oublier des etapes, donc le fichier permet de creer des rendez-vous en fonction de certains critères. Mais parfois le dossier tombe a l'eau. il faut donc qu'on nettoie complètement l'agenda.

je ne peux pas partager mon fichier original car c'est un pour ce projet de fin d'etude, et d'autres etudiants trainent aussi sur ce site et tout mon travail serait récupéré. dans le fichier original, il y a des critères supplémentaires qui font que toutes les lignes ne créé pas de rendez-vous !

un grand merci pour votre reponse déjà, je me sens moins seule !

merci merci !

Bonsoir,

ci-dessous proposition de code :

Sub supp_rdv()

    Dim OlApp As New Outlook.Application
    Dim calendrier As Outlook.Folder
    Dim rdvs_trouvés As Outlook.Items
    Dim rdv As Outlook.AppointmentItem
    Dim filtre As String
    Dim DEBUT As Date, FIN As Date, date_rech As Date
    Dim L As Integer

    '//création application
    Set OlApp = Outlook.Application

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

    '//traitement
    With Feuil1
        For L = 23 To 194

            If .Cells(L, "W") <> "" And .Cells(L, "O") = "RDV créé" Then

                'affectation début et fin du rdv
                DEBUT = DateValue(.Cells(L, "W")) + .Cells(L, "Q")
                FIN = DateValue(.Cells(L, "W")) + .Cells(L, "R")

                'recherche des rdvs correspondant à la date de début
                date_rech = DEBUT
                filtre = "[Start] > '" & Format(date_rech - 1, "ddddd") & "'" & "And" & "[Start] < '" & Format(date_rech + 1, "ddddd") & "'"
                Set rdvs_trouvés = calendrier.Items.Restrict(filtre)

                'suppression des rdvs trouvés si correspondance avec début et fin
                For Each rdv In rdvs_trouvés
                    If rdv.Start = DEBUT And rdv.End = FIN Then rdv.Delete
                Next rdv

            End If

        Next L
    End With

    Set OlApp = Nothing

End Sub

Bonjour THEV,

Merci pour le code ! Je viens de le tester.

Il pète une erreur sur cette ligne : If .Cells(L, "W") <> "" And .Cells(L, "O") = "RDV Créé" Then

Le pop-up indique "Objet requis"

La ligne en question veut elle dire : " Si la ligne W est différent de vide et si la colonne O contient rendez-vous créé, alors " ?

Si oui, qu'est-ce qu'il manque comme objet ? Je vien de faire le tour du forum pour savoir ce qu'était un objet, et je comprend qu'il s'agit de ma "feuil 1" , et les colonnes non ?

Bon je progresse !

j'ai ajouté WORKSHEETS("Feuil1") et je n'ai plus d'erreur lié à l'objet

Par contre maintenant, j'ai 2 autres erreurs :

ça me dit ceci :

Next sans For

et END sans WITH

je ne comprends pas trop pourquoi puisque qu'on à bien un IF.

Et pourquoi il faut mettre un Next L ?

;)

Rebonjour,

j'ai trouvé quelques solutions , je n'ai plus d'erreur, par contre, les rendez-vous ne s'effacent pas dans le calendrier Outlook !

(j'ai ajouté un end if)

voici le code :

Sub supp_rdv()

Dim OlApp As New Outlook.Application
Dim calendrier As Outlook.Folder
Dim rdvs_trouvés As Outlook.Items
Dim rdv As Outlook.AppointmentItem
Dim filtre As String
Dim DEBUT As Date, FIN As Date, date_rech As Date
Dim L As Integer

'//création application
Set OlApp = Outlook.Application

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

'//traitement
With Worksheets("Feuil1")
For L = 23 To 194

If .Cells(L, "W") <> "" And .Cells(L, "O") = "RDV Créé" Then

'affectation début et fin du rdv
DEBUT = DateValue(.Cells(L, "W")) + .Cells(L, "Q")
FIN = DateValue(.Cells(L, "W")) + .Cells(L, "R")

'recherche des rdvs correspondant à la date de début
date_rech = DEBUT
filtre = "[Start] > '" & Format(date_rech - 1, "ddddd") & "'" & "And" & "[Start] < '" & Format(date_rech + 1, "ddddd") & "'"
Set rdvs_trouvés = calendrier.Items.Restrict(filtre)

'suppression des rdvs trouvés si correspondance avec début et fin
For Each rdv In rdvs_trouvés
If rdv.Start = DEBUT And rdv.End = FIN Then rdv.Delete
Next rdv
End If
Next L
End With

Set OlApp = Nothing

End Sub

j'ai trouvé quelques solutions , je n'ai plus d'erreur, par contre, les rendez-vous ne s'effacent pas dans le calendrier Outlook !
D'abord, SVP utilisez la balise "</>" pour insérer du code.

Ensuite, vérifiez les dates de début et les dates de fin. Avec votre exemple et le code fourni, elles sont identiques ??

Après, faites une exécution pas à pas pour voir si vous arrivez à l'instruction :

If rdv.Start = DEBUT And rdv.End = FIN Then rdv.Delete

ce qui signifiera que les rdvs commençant à la date de début ont bien été retrouvés.

Ah ok ^^

Désolé je débute !

Oui en effet mes dates sont identiques dans mon fichier test, et dans la réalités ça pourra arriver que certaines dates soient identiques, mais pas toutes.

J'ai 2 questions : ou je rajoute cette ligne de code ?

If rdv.Start = DEBUT And rdv.End = FIN Then rdv.Delete

2eme question :

est-ce que le format de date peut avoir un impact sur le code ?

Dans ton code tu écris ceci :

filtre = "[Start] > '" & Format(date_rech - 1, "ddddd") & "'" & "And" & "[Start] < '" & Format(date_rech + 1, "ddddd") & "'"
Set rdvs_trouvés = calendrier.Items.Restrict(filtre)

Que veut dire "dddddd" ?

J'ai 2 questions : ou je rajoute cette ligne de code ?

If rdv.Start = DEBUT And rdv.End = FIN Then rdv.Delete

Nulle part. Cette instruction est déjà dans le code.

est-ce que le format de date peut avoir un impact sur le code ?

Oui

Dans ton code tu écris ceci :

filtre = "[Start] > '" & Format(date_rech - 1, "ddddd") & "'" & "And" & "[Start] < '" & Format(date_rech + 1, "ddddd") & "'"
Set rdvs_trouvés = calendrier.Items.Restrict(filtre)

Bonjour Thev,

J'ai rendu mon travail sans la fonctionnalité pour supprimer les rendez-vous, c'était un peu dur pour moi...!

Mais j'ai décidé de m'y recoller quand même, ça m'énerve d'être dans l'échec comme ça !

Je viens de repasser du temps sur quelques forum pour trouver la solution, sans succès pour le moment. Pourrais-tu me diriger vers un tutoriel ou autre pour m'aider ?

D'avance je te remercie ;)