Excel -> outlook calendrier partagé

Bonjour

Je viens vers vous,car suite à plusieurs heures de recherche je ne trouve pas de solution.

j'ai un fichier excel avec lequel je souhaite alimenter un calendrier partagé sur outlook.

j'arrive à mettre à jour mon calendrier mais quand je souhaite le faire sur un calendrier partagé cela ne fonctionne pas.

Je pense que tout cela peut etre optimisé.

merci d'avance pour votre aide

onglet Suivi, bouton 2

j'ai le message ci-dessous

code utilisé :

Sub Macro1()
'Dim DLig As Long, Lig As Long
' Dim OutObj As Object, OutAppt As Object
Dim DateRdv As Date, FlgRdv As Boolean
Dim HRDV As Date, Durée As Integer, Sujet As String
Dim OutlFolder As Outlook.MAPIFolder
Dim OutlApp As New Outlook.Application
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
Dim MyCalendar As Outlook.Items
Dim OutlMapi As Outlook.Namespace
Dim MyNamespace As Object
Dim ObjOutlook As Object
Set ObjOutlook = GetObject(, "Outlook.Application")
'Set MyNamespace = ObjOutlook.GetNamespace("test")
'Dim OutlFolder As Outlook.MAPIFolder
'Dim MyItem As Outlook.AppointmentItem
' Créer une instance d'Outlook
Set OutObj = CreateObject("outlook.application")
' Avec la feuille
With Sheets("Planning")
DLig = .Range("B" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 3 To DLig
' Si une date de relance existe
' Ainsi qu'une heure de RDV
If .Range("C" & Lig) <> "" _
And .Range("D" & Lig) <> "" And .Range("G" & Lig) = "" Then
FlgRdv = True
Else
FlgRdv = False
End If

' Si le FLAG est à vrai on créé le RDV
If FlgRdv = True Then
' Récupérer la date du RDV
DateRdv = .Range("C" & Lig).Value
' Récupérer l'heure de RDV
' Attention au format de l'heure saisie
On Error Resume Next
HRDV = .Range("D" & Lig).Value
If Err.Number <> 0 Then
Err.Clear
MsgBox "L'heure dans la colonne [D] doit être au format [hh:mm] exemple 08:00", vbCritical, "OUPS..."
Exit Sub
End If
On Error GoTo 0
' Récupérée la durée
Durée = .Range("E" & Lig).Value
' Si pas de durée, alors prendre celle par défaut
If Durée = 0 Then Durée = 0
' Créer le sujet du RDV
Sujet = "Opération" & .Range("B" & Lig).Value & " - Catégorie: " & .Range("F" & Lig).Value
' Créer le RDV sur OUTLOOK
Set OutAppt = OutObj.CreateItem(1)
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
'Set OutlItems = OutlFolder.Folders("test").Items
'MyNamespace.GetDefaultFolder.Folders("TEST").Items
With OutAppt
.Subject = Sujet
.Location = "Office " 'Lieu du rdv
.Start = DateRdv & " " & HRDV
.Duration = Durée
.ReminderSet = True
.Save
End With
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("G" & Lig) = "Added to Outlook"
.Range("G" & Lig).Comment.Delete
'.Range("G" & Lig).AddComment Text:=.Range("F" & Lig).Value
On Error GoTo 0
End If
Next Lig
End With
Set OutAppt = Nothing
End Sub