Sub NouveauRDV_Calendrier()
'nécessite d'activer la référence Microsoft Outlook 10.0 Object Library
Sheets("OUTIL STORE LOCATOR").Select
Dim myOlApp As New Outlook.Application
Dim MyItem As Outlook.AppointmentItem
Dim R As Range
For Each R In Range("H7", [H6].End(xlDown))
If R.Value = "" Then GoTo 1 'au suivant si la cellule semble vide
If R(1, 9) = "" Then
GoTo 1
Set MyItem = myOlApp.CreateItem(olAppointmentItem)
With MyItem
.MeetingStatus = olNonMeeting
.Subject = R
.Start = R(1, 3)
.Duration = R(1, 4)
.Location = R(1, 5)
.Save
End With
R(1, 9) = "ok"
End If
1 Next
Set MyItem = Nothing
End Sub