Recupérer données d'un calendrier outlook

Bonjour,

J'ai une procédure me permettant de récupérer les événements d'un calendrier outlook (commencant par *) pour être inséré dans un tableau excel et dans des userform.

Je lance cette procédure à l'ouverture de la feuille concernée ou en cliquant sur un bouton pour mettre à jour les valeurs.

Par contre cette procédure est très longue. (2 à 4 minutes environ)

Serait t-il possible d'accélérer cette procédure svp ?

peut-être en insérant dans un premier temps les données du calendrier dans un tableau et ensuite utiliser le tableau pour insérer les infos dans la feuille et l'userform ? (je maîtrise pas la gestion des tableaux)

Qu'en pensez vous ? Pourriez vous m'aider svp ?

Voici mon code :

Sub testcaloutlook()
Dim OutlApp As New Outlook.Application
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
'
Dim datedebut As String
Dim datefin As String
Dim S As String
Dim comb As String

Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.DisplayAlerts = False

' informe de la date de début et de fin des événemets du calendrier à rechercher
datedebut = Date - 10
datefin = Date + 90
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items

' efface les valeurs des cellules de la ligne 54 comprise entre la date de début et de la la date de fin de la ligne 55
 Set plage2 = ThisWorkbook.Worksheets("Stats repas").Range("f55:oi55")
    For Each Cell In plage2
        col1 = Cell.Column
        col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
        If Cell.Value > CDate(datedebut) And Cell.Value < CDate(datefin) Then
            Cell.ClearComments
            Cells(54, col).ClearContents
        End If
    Next Cell

Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")

While TypeName(OutlAppointment) <> "Nothing"
    If OutlAppointment.Start > datedebut And OutlAppointment.Start < datefin Then
    S = Left(OutlAppointment.Subject, 1)
    ' recherche événements du calendrier commencant par *
    If S = "*" Then
        ddd1 = Format(OutlAppointment.Start, "dd/mm/yyyy")
        ddd2 = Format(OutlAppointment.Start, "hh:mm")
        ' recherche colonne de la date
        For Each Cell In plage2
            If Cell.Value = CDate(ddd1) Then
                col1 = Cell.Column
                col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
            End If
        Next Cell
            ' copie valeurs de l evenement du calendrier dans la cellule
            If Cells(54, col1) = "" Then
            Cells(54, col1) = OutlAppointment.Subject
            Cells(54, col1).ShrinkToFit = True
            Cells(52, col1) = OutlAppointment.Subject & " " & OutlAppointment.Location
            Else
            Cells(54, col1) = Cells(54, col1) & Chr(10) & OutlAppointment.Subject
            Cells(52, col1) = Cells(52, col1) & Chr(10) & OutlAppointment.Subject & " " & OutlAppointment.Location
            End If
    End If
    End If
    Set OutlAppointment = OutlItems.FindNext
Wend

Application.ScreenUpdating = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

Je vous remercie beaucoup de votre aide

Cordialement

Bonjour,

A priori tu as pratiquement fait le maximum ...

Tu pourrais ajouter en début et en fin de macro

Application.Calculation = xlCalculationManual

Application.Calculation = xlCalculationAutomatic

En espèrant que cela améliore les choses ...

Merci beaucoup

Maintenant ca prend que quelques secondes, trop cool

Encore MERCI

Ravi que cela t'aide ...

Merci pour tes remerciements

Autre petite question

J'avais fait des corrections il y a quelques temps sur mon classeur

et depuis au démarrage j'ai le message :

"Pour l'instant nous ne parvenons pas à mettre à jour certaines des liaisons de votre classeur

Vous pouvez continuer sans mettre à jour leurs valeurs ou modifier les liaisons qui semblent incorrectes

CONTINUER - MODIFIER LIAISONS"

quand je clique sur MODIFIER LIAISONS mes 2 liaisons ont un état OK

Pourquoi donc avoir ce message si mes liaisons sont ok ?

Avez vous une explication svp ?

J'ai essayé d'aller dans rechercher, noter .xl ou [ dans rechercher et regarder dans formules mais il ne trouve aucune formule ???

Je vous remercie de votre aide

Cordialement

Re,

A priori il s'agit simplement d'une configuration de sécurité ... que tu peux modifier en allant dans les Options d'Excel ...

Autant pour moi

J'ai trouvé l'erreur

J'avais dans "gestionnaires de noms" des noms avec des références inconnues, je les ai supprimés et le message a disparu

Bonne journée