Alerte outlook provenant de date d'échéance tableau Excel

Bonjour,

Voilà je souhaite avoir des alertes dans outlook, quand ma date d'échéance arrive au jour j ou dépassé,

simplement, il me prend que ma première ligne

Pouvez-vous m'aider s'il vous plait à y voir plus clair

Merci beaucoup

Cordialement

Bonjour Mouchette

Vous utilisez un tableau structuré dans votre fichier que j'ai renommé "TabSuivi"

Utilisez donc ce code

Sub AddAppointments()
  Dim Lo As ListObject
  Dim dLig As Long, Lig As Long
  Dim xOutApp As Object
  Dim xOutItem As Object
  ' Définir le tableau structuré
  Set Lo = Sheets("SUIVI DES COMMANDES").ListObjects("TabSuivi")
  ' Dernière ligne du tableau
  dLig = Lo.DataBodyRange.Rows.Count
  ' Créer une instance Outlook
  Set xOutApp = CreateObject("Outlook.Application")
  ' Pour chaque ligne du corps tableau
  For Lig = 1 To dLig
    Set xOutItem = xOutApp.createitem(1)
    xOutItem.Subject = Lo.ListColumns("SUBJECT").DataBodyRange(Lig).Value
    xOutItem.Location = Lo.ListColumns("LOCATION").DataBodyRange(Lig).Value
    xOutItem.Start = Lo.ListColumns("START DATE").DataBodyRange(Lig).Value
    xOutItem.Duration = Lo.ListColumns("DURATION").DataBodyRange(Lig).Value
    If Trim(Lo.ListColumns("BUSY STATUS").DataBodyRange(Lig).Value) = "" Then
      xOutItem.BusyStatus = 2
    Else
      xOutItem.BusyStatus = Lo.ListColumns("BUSY STATUS").DataBodyRange(Lig).Value
    End If
    If Lo.ListColumns("REMINDER TIME").DataBodyRange(Lig).Value > 0 Then
      xOutItem.ReminderSet = True
      xOutItem.ReminderMinutesBeforeStart = Lo.ListColumns("REMINDER TIME").DataBodyRange(Lig).Value
    Else
      xOutItem.ReminderSet = False
    End If
    xOutItem.Body = Lo.ListColumns("BODY").DataBodyRange(Lig).Value
    xOutItem.Save
    Set xOutItem = Nothing
  Next
  Set xOutApp = Nothing
End Sub

@+

Bonjour BrunoM45,

Merci beaucoup pour votre aide,

Je dois renommer mon "suivi des commandes alerte" par TabSuivi car j'ai un message d'erreur

Cordialement

Re-Bonjour Bruno,

Voici le message d'erreur, j'ai mis mon tableau excel, je n'arrive pas .....................

je suis un peu perdue

Merci beaucoup

Re,

Un grand merci BrunoM45 c'est super

trop gentil

Cordialement

BrunoM45,

Encore une petite question,

Comment faire pour que je n'ai pas les rappels en double

Car quand je clique sur le bouton alerte, il me remet les lignes qu'ils sont déjà en alerte

Merci

Re,

Il faut ajouter un commentaire par exemple comme quoi le RDV a été créé et tester la cellule si le commentaire existe

Voici le code

Sub AddAppointments()
  Dim Lo As ListObject
  Dim dLig As Long, Lig As Long
  Dim xOutApp As Object
  Dim xOutItem As Object
  Dim Com As Comment
  ' Définir le tableau structuré
  Set Lo = Sheets("SUIVI DES COMMANDES").ListObjects("TabSuivi")
  ' Dernière ligne du tableau
  dLig = Lo.DataBodyRange.Rows.Count
  ' Créer une instance Outlook
  Set xOutApp = CreateObject("Outlook.Application")
  ' Pour chaque ligne du corps tableau
  For Lig = 1 To dLig
    ' Vérifier si un commentaire de RDV existe
    Set Com = Lo.ListColumns("SUBJECT").DataBodyRange(Lig).Comment
    ' Si existe, RDV déjà créé, on passe
    If Not Com Is Nothing Then GoTo SuiteLig
    ' Sinon
    Set xOutItem = xOutApp.createitem(1)
    xOutItem.Subject = Lo.ListColumns("SUBJECT").DataBodyRange(Lig).Value
    xOutItem.Location = Lo.ListColumns("LOCATION").DataBodyRange(Lig).Value
    xOutItem.Start = Lo.ListColumns("START DATE").DataBodyRange(Lig).Value
    xOutItem.Duration = Lo.ListColumns("DURATION").DataBodyRange(Lig).Value
    If Trim(Lo.ListColumns("BUSY STATUS").DataBodyRange(Lig).Value) = "" Then
      xOutItem.BusyStatus = 1
    Else
      xOutItem.BusyStatus = Lo.ListColumns("BUSY STATUS").DataBodyRange(Lig).Value
    End If
    If Lo.ListColumns("REMINDER TIME").DataBodyRange(Lig).Value > 0 Then
      xOutItem.ReminderSet = True
      xOutItem.ReminderMinutesBeforeStart = Lo.ListColumns("REMINDER TIME").DataBodyRange(Lig).Value
    Else
      xOutItem.ReminderSet = False
    End If
    xOutItem.Body = Lo.ListColumns("BODY").DataBodyRange(Lig).Value
    xOutItem.Save
    ' Inscrire le commentaire d'envoi
    With Lo.ListColumns("SUBJECT").DataBodyRange(Lig)
      .AddComment
      .Comment.Visible = False
      .Comment.Text Text:="RDV créé le " & Format(Now(), "dd/mm/yyyy hh:mm")
    End With

SuiteLig:
  Next
  ' Effacer les variables objet
  Set xOutApp = Nothing
  Set xOutItem = Nothing
End Sub

@+

Bonjour Bruno,

Merci pour ton aide,

Je dois créer une cellule avec un commentaire ?

Car j'ai simplement fait un copier coller de tes codes mais ca ne marche pas, elles sont toujours en double

Cordialement

Re,

Oui un simple copier/coller normalement

Mais attention je ne supprime pas les RDV déjà existant il faut le faire manuellement 😜

J'avais bien entendu testé avant de le poster

@+

Bruno un grand merci

j'ai un message d'erreur

End Sub
xOutItem.Body = Lo.ListColumns("BODY").DataBodyRange(Lig).Value
xOutItem.Save

DataBodyRange(Lig) est en bleu

Mouchette sérieux

Il ne faut pas me coller le code n'importe comment et n'importe où

Tout ce qui est après le 1er End Sub est à supprimer

@+

Bonjour Bruno,

J'espère que vous avez passé un bon week-end,

Un grand merci pour votre aide,

J'ai loupé surement un code car ça ne marche pas pour moi.

Je vais laisser comme ça et supprimer au fur et à mesure,

En tout cas, un grand merci pour votre patience, et votre réactivité,

Bonjour Mouchette

Si je puis me permettre, bonjour le suivi

Je vous ai donné un code ICI
https://forum.excel-pratique.com/s/goto/1009725

Il n'est plus dans le fichier donné en dernier alors comment voulez-vous que ça fonctionne

Faut vraiment tout faire... le voici corrigé

@+

Mille merci pour votre patience

Vous êtes vraiment trop gentil,

C'est le top

Cordialement

Re,