Microsoft 365 aide VBA excel

francis beauregard à dit:

Bonjour,

j'ai un document de suivi de communication dans lequel je veux ajouter des rappels dans mon calendrier outlook a une date de relance. Ça fonctionne, par contre si je veux entrer un suivi sans date de relance, il y a un bug.

est-ce que quelqu'un peut m'aider dans ma routine svp.

Merci

Sub AjoutRV()
Dim DLig As Long, Lig As Long
Dim OutObj As Object, OutAppt As Object
Dim DateRdv As Date, FlgRdv As Boolean
Dim sFilter As String
Dim oAppointment As Outlook.AppointmentItem

Dim namespaceOutlook As Outlook.Namespace
Dim DossierCalendrier As Outlook.MAPIFolder


' Créer une instance d'Outlook
Set OutObj = CreateObject("outlook.application")
Set namespaceOutlook = OutObj.GetNamespace("MAPI")

Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar)
' Avec la feuille
With Sheets("Suivi")
DLig = .Range("B" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 14 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("L" & Lig) <> "" Then
' Si le commentaire à changé
If .Range("L" & Lig).Comment.Text <> .Range("E" & 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("I" & Lig)
Set OutAppt = OutObj.CreateItem(1)
sFilter = "[Subject] = 'Faire suivi à " & Sheets("Suivi").Range("C" & Lig) & " au " & Sheets("Suivi").Range("G" & Lig) & "' "
Set oAppointment = DossierCalendrier.Items.Find(sFilter)

If Not oAppointment Is Nothing Then
With oAppointment
.Subject = "Faire suivi à " & Sheets("Suivi").Range("C" & Lig) & " au " & Sheets("Suivi").Range("G" & Lig)
.Duration = 60
.Start = DateRdv & " 08:00"
.ReminderSet = True
.Body = Range("H" & Lig)
.Save
End With
Else
With OutAppt
.Subject = "Faire suivi à " & Sheets("Suivi").Range("C" & Lig) & " au " & Sheets("Suivi").Range("G" & Lig)
.Duration = 60
.Start = DateRdv & " 08:00"
.ReminderSet = True
.Body = Range("H" & Lig)
.Save
End With
End If

' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("L" & Lig).Comment.Delete
.Range("L" & Lig).AddComment Text:=.Range("E" & Lig).Value
.Range("L" & Lig) = "Oui"
On Error GoTo 0
End If
Next Lig
End With
Set OutAppt = Nothing

End Sub

Cliquez pour agrandir...