Création d'un rdv outlook à partir d'excel dans plusieurs calendriers

Option Explicit

Sub AjoutRV()
  Dim DLig As Long, Lig As Long
  Dim OutObj As Outlook.Application
  Dim OutAppt As Outlook.AppointmentItem
  Dim DateRdv As Date, FlgRdv As Boolean

  ' Créer une instance d'Outlook
  Set OutObj = CreateObject("outlook.application")
  ' Avec la feuille
  With Sheets("2014")
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne
    For Lig = 2 To DLig
      ' Si une date de relance existe
      If .Range("B" & Lig) <> "" Then
        ' Si un RDV n'a pas déjà été créé
        If .Range("N" & Lig) <> "" Then
          ' Si le commentaire à changé
          If .Range("N" & Lig).Comment.Text <> .Range("C" & Lig).Value Then
            FlgRdv = True
          Else
            ' Sinon le commentaire n'a pas changé = pas de RDV
            FlgRdv = False
          End If
        Else
          ' Sinon, pas de RDV déjà créé
          FlgRdv = True
        End If
      Else
        ' Sinon, pas de date de relance
        FlgRdv = False
      End If
      ' Si le FLAG est à vrai on créé le RDV
      If FlgRdv Then
        DateRdv = Range("G" & Lig)
        Set OutAppt = OutObj.CreateItem(olAppointmentItem)
        With OutAppt
          .Subject = "Rappeler " & Sheets("2014").Range("A" & Lig) & " pour " & Sheets("2014").Range("A" & Lig)
          .Start = DateRdv & " 08:00"
          .Duration = 60
          .ReminderSet = True
          .Save
        End With
        ' Créer le commentaire et inscrire Oui
        On Error Resume Next
        .Range("N" & Lig).Comment.Delete
        .Range("N" & Lig).AddComment Text:=.Range("C" & Lig).Value
        .Range("N" & Lig) = "Oui"
        On Error GoTo 0
      End If
    Next Lig
  End With
  Set OutAppt = Nothing
End Sub