Plage de dates pour rdv - VB / Excel / Outlook

Résolu
Bonjour,

Je suis très novice en matière de VB, veuillez m'excuser.
Je cherche à créer des rdv Outlook à partir d'une liste de dates au format JJ.MM.AAAA, en l'occurrence des jours de congé.
Ces dates sont individuellement entrées dans une plage de cellules A4:A19


Sub NouveauRDV_Calendrier()

Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem

Set Rdv = OkApp.CreateItem(olAppointmentItem)

With Rdv
.MeetingStatus = Meeting
.Subject = "Vacances"
.Start = "02.06.2016"
.AllDayEvent = True
.Categories = "Congé"
.ReminderSet = False
.Save
End With

Set OkApp = Nothing
End Sub


J'utilise le code suivant, qui fonctionne très bien (il me crée bien un rendez-vous le 2 juin 2016), mais il faut entrer la date manuellement, auriez-vous peut-être une astuce pour que la macro prenne automatiquement chaque date individuelle pour assigner un rendez-vous à chacune ?

Merci d'avance pour votre aide !

Guy

1 réponse


  1. Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim dates, date_i As Range

    Set dates = Range("A4:A19")
    For Each date_i In dates.Rows
    If IsDate(date_i.Value) Then
    Set Rdv = OkApp.CreateItem(olAppointmentItem)
    With Rdv
    .MeetingStatus = Meeting
    .Subject = "Vacances"
    .Start = date_i.Value
    .AllDayEvent = True
    .Categories = "Congé"
    .ReminderSet = False
    .Save
    End With
    End If
    Next

    Set OkApp = Nothing

    End Sub

    --
     
    1. C'est magnifique, tout fonctionne.

      Est-ce que j'ose vous demander si vous connaissez un moyen simple de paramétrer la macro pour ajouter uniquement les nouvelles dates dans Outlook (si la plage augmente) à chaque exécution ?

      Si non, ce n'est pas grave, je peux aussi supprimer les doublons de l'exécution précédente dans le calendrier.

      Merci d'avance et bonne journée,
      Guy
    2. @ZhiteappleLe plus simple est de sélectionner avant lancement de la macro, la plage verticale des dates à ajouter, auquel cas le code devient

      Sub NouveauRDV_Calendrier()

      Dim OkApp As New Outlook.Application
      Dim Rdv As Outlook.AppointmentItem
      Dim dates, date_i As Range

      Set dates = Selection
      For Each date_i In dates.Rows
      If IsDate(date_i.Value) Then
      Set Rdv = OkApp.CreateItem(olAppointmentItem)
      With Rdv
      .MeetingStatus = Meeting
      .Subject = "Vacances"
      .Start = date_i.Value
      .AllDayEvent = True
      .Categories = "Congé"
      .ReminderSet = False
      .Save
      End With
      End If
      Next

      Set OkApp = Nothing

      End Sub
    3. @thevC'est parfait !
      Merci encore pour votre aide.

      Guy