XL 2010 VBA Outlook Excel_plusieurs RV dans un même calendrier

[Fred_Garnier]

Bonjour,

Novice mais non découragée je me permets de vous solliciter pour 2 soucis que je rencontre dans ma macro excel qui incrémente automatiquement des RDV dans outlook (calendrier partagé et non le principal):
1) je souhaite effacer les RV au départ pour intégrer toutes les modifications
2) je souhaite mettre plusieurs RDV différents (plusieurs conseillers) sur une même date et plage horaire.

J'avoue que je suis perdue.
Un grand merci pour votre aide,

Voici ma macro actuelle (chopée sur internet et adaptée pour mes besoins) :

Sub calendrier_Click()
Dim DateDebut As String
Dim OutlApp As New Outlook.Application
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
Dim myOlApp As New Outlook.Application
Dim MyCalendar As Outlook.Items
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim MyItem As Outlook.AppointmentItem
Dim myNamespace As Outlook.Namespace
Dim Cell As Range
Dim cal As String


'plage de donnée
cal = Sheets("2021").Range("C1")
For Each Cell In Sheets(cal).Range("E7:E1260")
'fin de plage de donnée

If Cell <> "" Then 'recherche dans la plage si il existe des données à inscrire
DateDebut = Cell.Offset(0, -2) & " " & Cell.Offset(0, -1) 'date pour vérification de doublons

Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = myOlApp.GetNamespace("MAPI").Folders.Item(1).Folders.Item(5).Folders.Item(1).Items

'verifie s'il y a des doublons
On Error Resume Next
Set OutlAppointment = OutlItems.Find("[Start] = '" & DateDebut & "'")
On Error GoTo 0
'fin vérification doublon

If OutlAppointment Is Nothing Then 's'il n'y a pas de doublons lancement du code
'On choisi le calendrier
Set myOlApp = CreateObject("Outlook.Application")
'Concernant la ligne suivante après le ("MAPI")
' Folders.Item(1) : correspond au dossier Personnel
' Folders.Item(5) : correspond au dossier Calendrier standard
' Folders.Item(1) : correspond au sous calendrier, s'il y en a d'autre remplacer par le n° d'index...
Set MyCalendar = myOlApp.GetNamespace("MAPI").Folders.Item(1).Folders.Item(5).Folders.Item(1).Items 'choix calendrier perso
'Fin choix calendrier


Set MyItem = MyCalendar.Add(olAppointmentItem) 'Set MyItem = myOlApp.CreateItem(olAppointmentItem)
With MyItem 'inscription des données dans excel
.MeetingStatus = olNonMeeting 'meeting
.ReminderSet = False ' S'il y a un rappel
.Subject = Cell.Offset(0, 2) & "_" & Cell.Offset(0, 1) & "_" & Cell.Offset(0, 0) 'Sujet
.Start = Cell.Offset(0, -2) & " " & Cell.Offset(0, -1) ' Date plus heure. Attention : format mm/dd/yy
.AllDayEvent = False ' Toute la journée oui/non
.Duration = 120 'minutes"
.Location = Cell.Offset(0, 3) 'emplacement et body pour les commentaires ou sujets
.Categories = Cell.Offset(0, 4)
'corps mail.body = "N° : " & Cell.Offset(0, 0) _
& vbCrLf _
& "Titre : " & Cell.Offset(0, 1) _
& vbCrLf _
& "Nom : " & Cell.Offset(0, 2) _
& vbCrLf _
& "Lieu : " & Cell.Offset(0, 3)
.Save
End With
Set MyItem = Nothing
Else
GoTo Passe '< ****** RAJOUTE CECI
End If
Else
Cell = "" 'si la plage de donnée est vide on quitte le macro
Exit Sub
End If
Passe: '< ****** RAJOUTE CECI
Next Cell 'tant que les cellules de la plage est complete on relance le macro

End Sub