Microsoft 365 aide VBA excel

francis beauregard

XLDnaute Nouveau
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

XLDnaute Nouveau
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
 

Pièces jointes

  • suivi des com test3.xlsm
    70.9 KB · Affichages: 5

Oneida

XLDnaute Impliqué
Bonjour,

1/ La date de relance est en colonne I et vous testez colonne B!
VB:
 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!
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
314 863
Messages
2 113 650
Membres
111 930
dernier inscrit
fab_met