Créer un rdv Outlook pour chaque date d'une colonne Excel
Ok je me doute mais sa me parais un peu compliquer comme processus
mon tableau ce décomposer comme dans le fichier joint
le feuille correspond au mois la colonne A au numéro des semaines colonne b la date colonne c le jour colonne D les am et pm
je sais récupérer le nom de la feuilles active qui me donne le mois mais après pour associer la date et am ou pm je patauge un peu
pour récupérer le mois de la feuille active
je fait comme sa:
[codeDim mois As String
mois = ActiveSheet.Name][/code]
mais apres pour tous assembler date jour mois la je sais pas comment faire
activecell et offset peut il me permettre de recuperer les valeur de mes cellules?
merci de votre aide
Re bonjour,
j'ai commencer un coder un bout de script vba mon premier
Sub tets()
Dim mois As String
mois = ActiveSheet.Name
Dim titre As String
Dim jour As Integer
Dim periode As String
While ActiveCell.Value <> ""
strjour = ActiveCell.Value
jour = ActiveCell.Offset(0, 1).Value
periode = ActiveCell.Offset(0, 2).Value
ActiveCell.Offset(0, 2).Value = periode
MsgBox (jour & " " & strjour & ": c'est " & periode & "mois" & mois & titre)
ActiveCell.Offset(1, 0).Select
Wend
End Subbon sa fait pas toute a fait ce que je veux je récupère bien mes infos dans la texte box le jour en chiffre et le jour en abréviation am ou pm
ce que je n arrive pas a faire c'est mettre des variable fixe pour am et pm et insérer le titre de mon rdv sur la cellule d après
qd j aurai réussi a faire sa je pourrai essayer d intégré sa a votre script de prise de rdv
merci à tous pour votre aide au débutant...
Hello,
juste un grand merci à BrunoM45 pour vos lumières - aide - info, bref pour le gros coup de pouce sur les macros pour créer un rdv Outlook. Me suis grandement inspirée de ceux disponibles dans cette discussion pour faire la mienne alors que je n'ai que très peu de connaissances en vba.
Muriel68 a écrit :Hello,
juste un grand merci à BrunoM45 pour vos lumières - aide - info, bref pour le gros coup de pouce sur les macros pour créer un rdv Outlook. Me suis grandement inspirée de ceux disponibles dans cette discussion pour faire la mienne alors que je n'ai que très peu de connaissances en vba.
Merci Muriel68
Ca fait toujours très plaisir
Bonjour BrunoM45,
Tout d'abord merci pour tes connaissances et l'aide que tu apportes sur le forum
Je débute sur les macros et après fait des essais par moi même, j'ai trouvé le code que tu avais réalisé pour créer des alertes dans Outlook.
J'ai pris le dernier fichier (celui pour Emoelha) et je dois dire que je suis très satisfaite du résultat mais j'ai un petit problème avec la macro "Ajour dernier RDV", elle fonctionne mais ne crée un RDV uniquement sur la dernière ligne
=> je viens de relire ton post et c'est parfaitement normal que la macro ne crée que le dernier RDV, elle est programmée pour ça ... LOL
J'ai essayé de modifier la macro en lui demandant de prendre la dernière cellule avec un commentaire oui mais j'ai lamentablement échoué (la macro se s’exécute pas)
Là je sèche, et vu mon niveau, je suis en panne d'idée, pourrais tu m'aider stp ? Ci joint mon fichier de travail
Merci beaucoup pour ton aide,
Bonne journée
Bonjour, Est-ce possible d'adapter ta formule pour faire en sorte que si la même date reviens plusieurs fois, tous inclure dans le même rdv?
Merci
Bonjour Goldfinch86
Goldfinch86 a écrit :Bonjour, Est-ce possible d'adapter ta formule pour faire en sorte que si la même date reviens plusieurs fois, tous inclure dans le même rdv?
Merci
Ce n'est pas une formule, mais du code
Je regarde ça
Désolé, mon erreur, comme tu peux voir je ne suis pas encore habitué au codage. J'ai une autre question en même temps. Le fichier excel sur lequel je travail est partagé entre 4 personne, le calendrier dans lequel on envoie les rdv est aussi partager avec plus d'une vingtaine de personne, mais seulement les 4 personnes qui utilise le fichier excel peuvent modifier le calendrier. Le problème est que seul moi arrive a ajouter des rdv, pour les autres, il leur apparait un message d'erreur objet introuvable.
Voici mon code
Sub AjoutRDVCalendrier()
'déclaration des variables
Dim DLig As Long, Lig As Long
Dim oOutlook As Outlook.Application
Dim oAppointment As Outlook.AppointmentItem
Dim namespaceOutlook As Outlook.Namespace
Dim DossierCalendrier As Outlook.MAPIFolder
Dim DateRdv As Date, FlgRdv As Boolean
'gestion d'erreurs
On Error GoTo Err_Execution
'on crée ensuite les objets
Set oOutlook = CreateObject("Outlook.Application")
Set namespaceOutlook = oOutlook.GetNamespace("MAPI")
Set myTasks = namespaceOutlook.GetDefaultFolder(olFolderCalendar)
Set myFolder = myTasks.Folders("Communications")
'définit le dossier calendrier
'GetDefaultFolder renvoit le calendrier du compte actif
Set DossierCalendrier = myFolder
'on crée un nouveau rendez-vous
' Avec la feuille
With Sheets("Suivi")
DLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DLig
' Si une date de relance existe
If .Range("A" & Lig) <> "" Then
' Si un RDV n'a pas déjà été créé
If .Range("E" & Lig) <> "" Then
' Si le commentaire à changé
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("A" & Lig)
'on renseigne ensuite les principaux paramètres
Set oAppointment = DossierCalendrier.Items.Add
With oAppointment
.AllDayEvent = True
.Start = DateRdv
.Subject = Sheets("Suivi").Range("C" & Lig)
If Sheets("Suivi").Range("B" & Lig) = "" Then
'corps du texte de la réunion
.Body = "Bonjour tout le monde, voici un résumé de la journée." & vbLf & vbLf _
& Sheets("Suivi").Range("C" & Lig) & " : " & Sheets("Suivi").Range("D" & Lig)
Else
.Body = "Lot : " & Sheets("Suivi").Range("B" & Lig) & vbLf & vbLf _
& Sheets("Suivi").Range("C" & Lig) & " : " & Sheets("Suivi").Range("D" & Lig)
End If
.Location = "" 'Lieu du rdv
.ReminderSet = True 'alarme
.Save 'on sauvegarde et ferme
.Close (olSave)
End With
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("E" & Lig) = "Envoyé"
On Error GoTo 0
End If
Next Lig
End With
'Libération des variables.
Set oAppointment = Nothing
Set oOutlook = Nothing
Fin_Execution:
Exit Sub
Err_Execution:
MsgBox Err.Description, vbExclamation
Resume Fin_Execution
End SubMerci de regarder ca aussi
Re,
Pour moi ton problème d'ajout de RdV qui ne marche pas pour les autres vient de cette ligne :
Set myFolder = myTasks.Folders("Communications")Sinon je suis reparti du fichier que j'avais fait à l'époque, sans tes modifications
A+
Bonjour,
merci beaucoup, mais je cherche dans le fichier pour voir ou est la modif pour ma premiere question (date identique = un seul rdv) et je trouve pas. pour la deuxième question, si les autres ont nommé aussi leur calendrier "Communications" et qu'il est aussi dans la section "Mes Calendriers" sur Outlook, c'est pas sensé fonctionné pareil? D'après le code, j'ai l'impression pourtant que rien ne cloche...Mais comme j'ai dit plus tôt, je commence et je ne cherche qu'a apprendre.
Merci Bruno
Re,
Goldfinch86 a écrit :Bonjour,
merci beaucoup, mais je cherche dans le fichier pour voir ou est la modif pour ma premiere question (date identique = un seul rdv) et je trouve pas.
Heuuuu, j'ai dû tout changer
Option Explicit
Sub AjoutRdV1()
Dim DLig As Long, Lig As Long
Dim Ind As Long, TabRdv() As String
' Avec la feuille
With Sheets("SuiviSimple")
' Dernière ligne
DLig = .Range("A" & Rows.Count).End(xlUp).Row
Ind = -1
' Pour chaque ligne
For Lig = 2 To DLig
' Si une date de relance existe
If .Range("B" & Lig) <> "" Then
' Si aucun RDV n'a encore été créé
If .Range("D" & Lig) = "" Then
' Si la date n'exixte pas déjà dans le tableau
If Not EstDansTab(TabRdv, .Range("B" & Lig)) Then
Ind = Ind + 1
ReDim Preserve TabRdv(2, Ind)
TabRdv(0, Ind) = .Range("A" & Lig)
TabRdv(1, Ind) = .Range("B" & Lig)
TabRdv(2, Ind) = .Range("C" & Lig)
Else
' Sinon ajouter juste le texte
Ind = OuDansTab(TabRdv, .Range("B" & Lig))
TabRdv(2, Ind) = TabRdv(2, Ind) & Chr(10) & .Range("C" & Lig)
End If
' Si RDV déjà créé, mais commentaire <> du contenu de la cellule
ElseIf .Range("D" & Lig).Comment.Text <> .Range("C" & Lig).Value Then
If Not EstDansTab(TabRdv, .Range("B" & Lig)) Then
Ind = Ind + 1
ReDim Preserve TabRdv(2, Ind)
TabRdv(0, Ind) = .Range("A" & Lig)
TabRdv(1, Ind) = .Range("B" & Lig)
TabRdv(2, Ind) = .Range("C" & Lig)
Else
Ind = OuDansTab(TabRdv, .Range("B" & Lig))
TabRdv(2, Ind) = TabRdv(2, Ind) & Chr(10) & .Range("C" & Lig)
End If
End If
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("D" & Lig) = "Oui"
.Range("D" & Lig).Comment.Delete
.Range("D" & Lig).AddComment Text:=.Range("C" & Lig).Value
On Error GoTo 0
End If
Next Lig
End With
' Lancer la création des RDV
If Ind >= 0 Then
Call CréerRdV1(TabRdv)
MsgBox "Le/les RDV a/ont été créé(s)", vbInformation, "C'EST FAIT..."
Else
MsgBox "Aucun RDV supplémentaire à créer", vbInformation, "OUPS..."
End If
End Sub
Sub CréerRdV1(MonTab() As String)
Dim OutObj As Object, OutAppt As Object
Dim DateRdv As Date, FlgRdv As Boolean
Dim HRdV As Date, Durée As Integer, Sujet As String
Dim iTab As Long
' Créer une instance d'Outlook
Set OutObj = CreateObject("outlook.application")
' Récupérer les valeurs par défaut
HRdV = Sheets("Params").Range("HeureRDV").Value
Durée = Sheets("Params").Range("DuréeRDV").Value
' En cas de d'erreur
On Error GoTo FinBoucle
' Pour chaque ligne du tableau
For iTab = LBound(MonTab) To UBound(MonTab)
' Créer le sujet du RDV
Sujet = "Rappeler " & MonTab(0, iTab) & " pour " & MonTab(2, iTab)
Set OutAppt = OutObj.CreateItem(1)
With OutAppt
.Subject = Sujet
.Start = CDate(MonTab(1, iTab)) & " " & HRdV
.Duration = Durée
.ReminderSet = True
.Save
End With
Next iTab
FinBoucle:
End Sub
Sub AjoutRdV2()
Dim DLig As Long, HRdV As Date, Lig As Long
Dim Ind As Long, TabRdv() As String
' Avec la feuille
With Sheets("SuiviSimple")
' Dernière ligne
DLig = .Range("A" & Rows.Count).End(xlUp).Row
Ind = -1
'
' Vérifier la conformité des heures de RDV
On Error Resume Next
For Lig = 2 To DLig
HRdV = .Range("C" & Lig).Value
If Err.Number <> 0 Then
Err.Clear
MsgBox "L'heure de [C" & Lig & "] doit être au format [hh:mm] exemple 08:00", vbCritical, "OUPS..."
On Error GoTo 0
Exit Sub
End If
Next Lig
On Error GoTo 0
'
' Si tout est OK on passe à la suite
For Lig = 2 To DLig
' Si une date de RDV existe ainsi qu'un heure
If .Range("B" & Lig) <> "" And .Range("C" & Lig) <> "" Then
' Si aucun RDV n'a encore été créé
If .Range("F" & Lig) = "" Then
' Si la date n'est pas encore dans le tableau
If Not EstDansTab(TabRdv, .Range("B" & Lig)) Then
Ind = Ind + 1
ReDim Preserve TabRdv(4, Ind)
TabRdv(0, Ind) = .Range("A" & Lig)
TabRdv(1, Ind) = .Range("B" & Lig)
TabRdv(2, Ind) = .Range("C" & Lig)
TabRdv(3, Ind) = .Range("D" & Lig)
TabRdv(4, Ind) = .Range("E" & Lig)
Else
Ind = OuDansTab(TabRdv, .Range("B" & Lig))
TabRdv(4, Ind) = TabRdv(4, Ind) & Chr(10) & .Range("E" & Lig)
End If
ElseIf .Range("F" & Lig).Comment.Text <> .Range("F" & Lig).Value Then
If Not EstDansTab(TabRdv, .Range("B" & Lig)) Then
Ind = Ind + 1
ReDim Preserve TabRdv(4, Ind)
TabRdv(0, Ind) = .Range("A" & Lig)
TabRdv(1, Ind) = .Range("B" & Lig)
TabRdv(2, Ind) = .Range("C" & Lig)
TabRdv(3, Ind) = .Range("D" & Lig)
TabRdv(4, Ind) = .Range("E" & Lig)
Else
Ind = OuDansTab(TabRdv, .Range("B" & Lig))
TabRdv(4, Ind) = TabRdv(4, Ind) & Chr(10) & .Range("E" & Lig)
End If
End If
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("F" & Lig) = "Oui"
.Range("F" & Lig).Comment.Delete
.Range("F" & Lig).AddComment Text:=.Range("E" & Lig).Value
On Error GoTo 0
End If
Next Lig
End With
' Lancer la création des RDV
If Ind >= 0 Then
Call CréerRdV2(TabRdv)
MsgBox "Le/les RDV a/ont été créé(s)", vbInformation, "C'EST FAIT..."
Else
MsgBox "Aucun RDV supplémentaire à créer", vbInformation, "OUPS..."
End If
End Sub
Sub CréerRdV2(MonTab() As String)
Dim OutObj As Object, OutAppt As Object
Dim DateRdv As Date, FlgRdv As Boolean
Dim HRdV As Date, Durée As Integer, Sujet As String
Dim iTab As Long
' Créer une instance d'Outlook
Set OutObj = CreateObject("outlook.application")
' Récupérer les valeurs par défaut
HRdV = Sheets("Params").Range("HeureRDV").Value
Durée = Sheets("Params").Range("DuréeRDV").Value
' En cas de d'erreur
On Error GoTo FinBoucle
' Pour chaque ligne du tableau
For iTab = LBound(MonTab) To UBound(MonTab)
' Créer le sujet du RDV
Sujet = "Rappeler " & MonTab(0, iTab) & " pour " & MonTab(4, iTab)
Set OutAppt = OutObj.CreateItem(1)
With OutAppt
.Subject = Sujet
.Start = CDate(MonTab(1, iTab)) & " " & MonTab(2, iTab)
.Duration = MonTab(3, iTab)
.ReminderSet = True
.Save
End With
Next iTab
FinBoucle:
End SubPlus 2 fonctions
Option Explicit
Function EstDansTab(MonTab, Valeur As String) As Boolean
Dim iTab As Long
EstDansTab = False
On Error GoTo Fin
For iTab = LBound(MonTab) To UBound(MonTab)
If MonTab(1, iTab) = Valeur Then EstDansTab = True: Exit For
Next
Fin:
End Function
Function OuDansTab(MonTab, Valeur As String) As Long
Dim iTab As Long
OuDansTab = 0
For iTab = LBound(MonTab) To UBound(MonTab)
If MonTab(1, iTab) = Valeur Then OuDansTab = iTab: Exit For
Next
End FunctionGoldfinch86 a écrit :pour la deuxième question, si les autres ont nommé aussi leur calendrier "Communications" et qu'il est aussi dans la section "Mes Calendriers" sur Outlook, c'est pas sensé fonctionné pareil? D'après le code, j'ai l'impression pourtant que rien ne cloche...Mais comme j'ai dit plus tôt, je commence et je ne cherche qu'a apprendre.
Logiquement cela devrait fonctionner, mais attention tout de même, il faut qu'Outlook soit ouvert
A+
Merci vraiment beaucoup. Maintenant je vais essayer de le comprendre pour l'adapter, la tâche s'annonce difficile, mais merci vraiment de m'avoir débloquer, je ne savais plus quoi faire.
J'ai essayer ton fichier sans rien changer et quand il y a deux fois la même date ca renvoie une erreur a cette ligne "TabRdv(Ind, 0) = .Range("A" & Lig)"
If Not EstDansTab(TabRdv, .Range("B" & Lig)) Then
Ind = Ind + 1
TabRdv(Ind, 0) = .Range("A" & Lig)
TabRdv(Ind, 1) = .Range("B" & Lig)
TabRdv(Ind, 2) = .Range("C" & Lig)
ElseSi il y a une seul fois la date tout fonctionne.
J'essais aussi de comprendre ce que représente ces 2 variable
Dim Ind As Long, TabRdv(0, 2) As StringDésolé encore je t'en demande beaucoup.
Bonsoir,
Désolé, je ne l'avais pas testé correctement et je me suis encore planté dans le sens du tableau
En même temps, j'ai repensé à ton problème sur le fait que le code fonctionne sur ton poste mais pas sur les autres.
Le problème peut venir du fait que vous n'ayez pas les mêmes versions
Je n'ai donc pas mis de référence à Microsoft Outlook 2016 et déclaré les variables pour du Late Binding
https://support.microsoft.com/en-us/help/245115/using-early-binding-and-late-binding-in-automation
Voici donc le fichier adapté à ton besoin à essayer sur tous les postes
A+
Wow merci énormément!!!
Salut Bruno, j'ai un problème lorsque l'évenement se créer et combine plusieurs journées.
Voici ce que je devrait voir :
Bonjour tout le monde, voici un résumé de la journée.
Lot : 2017-11-28
Date 1 du 28/11 : Designation : 43067 Date 1 du 28/11
Date 2 du 28/11 : Designation : 43067 Date 2 du 28/11
Et voici ce que je vois :
Bonjour tout le monde, voici un résumé de la journée.
Lot : 2017-11-28
Date 1 du 28/11
Date 2 du 28/11 : Designation : 43067 Date 1 du 28/11
Designation : 43067 Date 2 du 28/11
Je cherche et je cherche, mais je ne trouve pas quoi changer.
Je me doute que le code a changer ce trouve dans cette partie :
If Not EstDansTab(TabRdv, .Range("A" & Lig)) Then
Ind = Ind + 1
ReDim Preserve TabRdv(3, Ind)
TabRdv(0, Ind) = .Range("A" & Lig)
TabRdv(1, Ind) = .Range("B" & Lig)
TabRdv(2, Ind) = .Range("C" & Lig)
TabRdv(3, Ind) = .Range("D" & Lig)
Else
' Sinon ajouter juste le texte
Ind = OuDansTab(TabRdv, .Range("A" & Lig))
TabRdv(1, Ind) = TabRdv(1, Ind) & Chr(10) & .Range("B" & Lig)
TabRdv(2, Ind) = TabRdv(2, Ind) & Chr(10) & .Range("C" & Lig)
TabRdv(3, Ind) = TabRdv(3, Ind) & Chr(10) & .Range("D" & Lig)
End IfJ'essais et essais, mais je n'arrive pas a le mettre dans l'ordre que je souhaite.
Merci Bruno à l'avance.
Et j'ai essayé sur les autres postes, cela m'écrit qu'il est impossible de trouver un objet...
Bonjour, je sais pas si quelqu'un peut m'aider avec ma dernière question. Je suis toujours dans l'impasse. Merci d'avance
Bonjour Goldfinch86 et bonne année 2018
Il serait bien de nous mettre un fichier avec ta structure actuelle et un exemple, ce serait plus simple dans la compréhension
Dans l'attente
Bonjour Bruno et bonne année à toi aussi!
Je n'ai rien changé au fichier que tu as joint le 23 novembre (Goldfinch86_RdvCommunications.xlsm). Je n'ai pas accès au fichier pour le moment, mais c'est exactement le même.
Merci, sinon dès lundi je pourrai te l'envoyer.