Problème macro Excel>>Outlook

[edberg67]

Bonjour à tous,

J'ai un petit soucis sur une macro VBA que j'ai faite.
J'ai un fichier Excel avec des dates de relances. J'ai écris une macro me permettant de créer des rappels dans outlook en fonction de la date de relance saisie dans excel.
Mon soucis, c'est que dès que je rajoute une ligne ou modifie une date, il me recopie toutes les lignes, donc il y a des doublons dans outlook.
je ne voudrais copier que les lignes ou il y a eu du changement, ou alors effacer les rappel outlokk avant de les recopier..Mais je beug!!!
Je vous mets mon code pour le transfert outlook:
Set OutObj = CreateObject("outlook.application")
' Avec la feuille
With Sheets("Suivi")
DLig = .Range("D" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 5 To DLig
' Si une date de relance existe
If .Range("I" & Lig) <> "" Then
' Si un RDV n'a pas déjà été créé
FlgRdv = True
Else
FlgRdv = False
End If
' Si le FLAG est à vrai on créé le RDV
If FlgRdv Then
DateRdv = Range("I" & Lig)
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
With OutAppt
.Subject = "Rappeler " & Sheets("Suivi").Range("D" & Lig)
.Start = DateRdv & " 08:00"
.Duration = 30
.ReminderSet = True
.Save
End With

End If
Next Lig
End With
Set OutAppt = Nothing
End If

Merci à tous pour votre aide!!
A bientôt

 

[Lone-wolf]

Bonjour edberg

Il faut modifier ces lignes

DLig = .Range("D" & Rows.Count).End(xlUp).Row

' Si une date de relance existe
If (.Range("I" & Lig) <> "" Then

Par
DLig = .Range("I" & Rows.Count).End(xlUp).Row
If .Range("I" & Lig).Value = Date Then