Sub NouveauRDV_Calendrier()
'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim myOlApp As New Outlook.Application
Dim MyItem As Outlook.AppointmentItem
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim Cell As Range
Set myNamespace = myOlApp.GetNamespace("MAPI")
Dim CalendarFolder As Outlook.MAPIFolder
Set myRecipient = myNamespace.CreateRecipient("s.a@a.fr")
myRecipient.Resolve
If myRecipient.Resolved Then
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
Else
Exit Sub
End If
For Each Cell In Range("A8:A" & Range("A22").End(xlUp).Row)
Set MyItem = myOlApp.CreateItem(olAppointmentItem)
With MyItem
.MeetingStatus = olNonMeeting
.Subject = Cell
.Start = Cell.Offset(0, 1) ' Attention : format mm/dd/yy
.Duration = Cell.Offset(0, 2) 'minutes
.Location = Cell.Offset(0, 3)
.Save
End With
Set MyItem = Nothing
Next Cell
End Sub