Private Sub calendrier_Click()
Dim DateDebut As String
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
Dim myOlApp As New Outlook.Application
Dim MyCalendar As Outlook.Items
Dim MyItem As Outlook.AppointmentItem
Dim myNamespace As Outlook.Namespace
Dim Cell As Range
Dim cal As String
'plage de donnée
cal = Sheets("Menu").Range("P3")
For Each Cell In Sheets(cal).Range("E2:E60")
'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
'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 outlook
.MeetingStatus = olNonMeeting 'meeting
.ReminderSet = False ' S'il y a un rappel
.Subject = Cell.Offset(0, 2) '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 = 105 'minutes"
.Location = Cell.Offset(0, 1) 'emplacement et body pour les commentaires ou sujets
.body = "N° : " & Cell.Offset(0, 0)
.Save
End With
Set MyItem = Nothing
Else: Next Cell 'si il y a deja un RDV alors retour vers date suivante
End If
Else: Cell = "" 'si la plage de donnée est vide on quitte le macro
Exit Sub
End If
Next Cell 'tant que les cellules de la plage est complete on relance le macro
End Sub
