Microsoft 365 aide VBA excel

[francis beauregard]

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

 

[francis beauregard]

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

 

[Oneida]

Bonjour,
Ce suivi sans date de relance partirait avec quoi, comment?

 

[francis beauregard]

En fait comme c'est un document de suivi de communication, il arrive de recevoir des communication que nous devons inscrire dans le tableau, par contre aucun suivi n'est nécessaire, donc aucune action ni rappel de devrait être créé pour ce suivi.

Merci

 

[Oneida]

Bonjour,

1/ La date de relance est en colonne I et vous testez colonne B!

 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

2/ Vous avez un tableau structure et vous utilisez des instructions cellules
Pourquoi un tableau si long vide surtout avec =AUJOURDHUI() dans toute la colonne Date du jour!