VBA Excel import appointment des calendriers partagés outlook

Bonjour,

J'essaye en vain de trouver une solution pour importer les items de plusieurs calendrier partagés simultanément.

Je parviens à le faire pour un calendriers partagé à l'aide de la macro ci-dessous.

Y-a-t-il une solution pour boucler sur les calendriers partagés définis ?

Merci pour votre aide.

Option Explicit

Public Sub ListAppointments()
On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9

    Dim OLApp       As Object: Set OLApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = OLApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olFolder2    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
    Dim objOwner2   As Object: Set objOwner2 = olNS.CreateRecipient("pierre.dupont@dom.fr")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = InputBox("Enter the start date (format: dd/mm/yyyy)")
   ToDate = InputBox("Enter the end date(format: dd/mm/yyyy)")

    objOwner.Resolve
    objOwner2.Resolve

    If (objOwner.Resolved And objOwner2.Resolve) Then
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
        Set olFolder2 = olNS.GetSharedDefaultFolder(objOwner2, olFolderCalendar)
        'Set olFolder = olNS.GetSharedDefaultFolder(9)
    End If
    Worksheets("calend").Cells.ClearContents
    ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")

    'Ensure there at least 1 item to continue
    Debug.Print olFolder.Items.Count
    Debug.Print objOwner.Name
    Debug.Print objOwner2.Name

    If (olFolder.Items.Count = 0 And olFolder2.Items.Count = 0) Then Exit Sub

    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 4, 0 To olFolder.Items.Count - 1)

    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next

    For Each olApt In olFolder.Items
    If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
    If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then

        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        myArr(4, NextRow) = objOwner.Name
        NextRow = NextRow + 1
        Else
        End If
        End If
    Next olApt
     Set olApt = Nothing
        Set olFolder = Nothing
        Set olNS = Nothing
        Set OLApp = Nothing
    On Error GoTo 0

    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:E" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

    'AutoFit
    ws.Columns.AutoFit

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrHand:
    'Add error handler
    Resume cleanExit
End Sub

Bonjour,

après plusieurs recherches, je ne trouve pas de solution.

Quelqu’un a-t-il déjà effectué ce type de macro.

Merci pour votre aide.

Bonsoir,

ci-dessous proposition de code :

Option Explicit

Public Sub ListAppointments()

    On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9
    Const olExchange As Byte = 0

    Dim OLApp As Object: Set OLApp = CreateObject("Outlook.Application")
    Dim compte As Object, récipient As Object
    Dim calendriers_partagés As Object, calendrier_partagé As Object
    Dim filtre As String
    Dim rdvts_trouvés As Object, olApt As Object
    Dim NextRow As Long
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
    Dim FromDate As Date
    Dim ToDate As Date
    Dim myArr()

    FromDate = CDate(InputBox("Enter the start date (format: dd/mm/yyyy)"))
    ToDate = CDate(InputBox("Enter the end date(format: dd/mm/yyyy)"))

    Worksheets("calend").Cells.ClearContents
    ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")

    For Each compte In OLApp.Session.Accounts
        If compte.AccountType = olExchange Then
            Set récipient = OLApp.Session.CreateRecipient(compte.DisplayName)
            Set calendriers_partagés = OLApp.Session.GetSharedDefaultFolder(récipient, olFolderCalendar)
            If Not calendriers_partagés Is Nothing Then GoSub Stockage_rdvts
        End If
    Next compte

    'Write all records to a worksheet from an array, this is much faster
    If UBound(myArr) > -1 Then ws.Range("A2").Resize(UBound(myArr)+1, 5).Value = Application.Index(myArr, 0, 0) _
    Else MsgBox "no appointment found"

    'AutoFit
    ws.Columns.AutoFit

    Set OLApp = Nothing
    On Error GoTo 0

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

Stockage_rdvts:
    For Each calendrier_partagé In calendriers_partagés.Folders

        'filtrage des rdvs correspondant à la fourchette de dates
        filtre = "[Start] > '" & FromDate & "'" & "And" & "[Start] < '" & ToDate + 1 & "'"
        Set rdvts_trouvés = calendrier_partagé.Items.Restrict(filtre)
        rdvts_trouvés.Sort "[Start]"

        'analyse des rdvts trouvés
        For Each olApt In rdvts_trouvés
            If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
                ReDim Preserve myArr(NextRow)
                myArr(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, calendrier_partagé.Name)
                NextRow = NextRow + 1
            End If
        Next olApt

    Next calendrier_partagé

    Return

ErrHand:
    'Add error handler
    Resume cleanExit
End Sub

Bonjour,

Je viens de mettre en place votre macro et je vous remercie.

Par contre, seul mon adresse email ressort dans la variable récipient.

De plus les rendez-vous de mon compte ne s'affiche pas dans la feuille calend

Je vous remercie pour votre aide.

Par contre, seul mon adresse email ressort dans la variable récipient.

C'est logique car c'est a priori le seul compte Microsoft Exchange dont vous disposez dans Outlook

De plus les rendez-vous de mon compte ne s'affiche pas dans la feuille calend

Sauf erreur, votre demande ne concernait que les calendriers partagés et non le calendrier associé à votre compte Microsoft Exchange. Reprécisez votre demande.

Bonjour,

J'ai accès en lecture avec tous les détails aux calendriers de mes collègues.

Ces calendriers se trouvent dans le dossiers Calendriers partagés de mon clients outlook.

Je parviens bien à faire la requête des rendez-vous individuellement, avec la macro ci-dessous

Par contre je souhaiterais les requêter ensemble pour récupérer les rendez-vous de tous par une seule action.

Merci pour votre aide.

Option Explicit

Public Sub ListAppointments()
On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9

    Dim OLApp       As Object: Set OLApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = OLApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olFolder2    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
    Dim objOwner2   As Object: Set objOwner2 = olNS.CreateRecipient("pierre.dupont@dom.fr")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = InputBox("Enter the start date (format: dd/mm/yyyy)")
   ToDate = InputBox("Enter the end date(format: dd/mm/yyyy)")

    objOwner.Resolve
    objOwner2.Resolve

    If (objOwner.Resolved And objOwner2.Resolve) Then
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
        Set olFolder2 = olNS.GetSharedDefaultFolder(objOwner2, olFolderCalendar)
        'Set olFolder = olNS.GetSharedDefaultFolder(9)
    End If
    Worksheets("calend").Cells.ClearContents
    ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")

    'Ensure there at least 1 item to continue
    Debug.Print olFolder.Items.Count
    Debug.Print objOwner.Name
    Debug.Print objOwner2.Name

    If (olFolder.Items.Count = 0 And olFolder2.Items.Count = 0) Then Exit Sub

    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 4, 0 To olFolder.Items.Count - 1)

    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next

    For Each olApt In olFolder.Items
    If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
    If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then

        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        myArr(4, NextRow) = objOwner.Name
        NextRow = NextRow + 1
        Else
        End If
        End If
    Next olApt
     Set olApt = Nothing
        Set olFolder = Nothing
        Set olNS = Nothing
        Set OLApp = Nothing
    On Error GoTo 0

    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:E" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

    'AutoFit
    ws.Columns.AutoFit

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrHand:
    'Add error handler
    Resume cleanExit
End Sub

ci-joint code listant vos calendriers partagés ainsi que le vôtre

Option Explicit

Public Sub ListAppointments()

    On Error GoTo ErrHand

    Application.ScreenUpdating = False

    'Constantes Outlook
    Const olFolderCalendar As Byte = 9
    Const olExchange As Byte = 0
    Const olAppointmentItem = 1

    'Variables Outlook
    Dim OLApp As Object: Set OLApp = CreateObject("Outlook.Application")
    Dim compte As Object, récipient As Object, dossier As Object
    Dim calendriers_partagés As Object, calendrier As Object
    Dim filtre As String, ref_calendrier As String
    Dim rdvts_trouvés As Object, olApt As Object
    Dim NextRow As Long
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
    Dim FromDate As Date, ToDate As Date
    Dim myArr()

    FromDate = CDate(InputBox("Enter the start date (format: dd/mm/yyyy)"))
    ToDate = CDate(InputBox("Enter the end date(format: dd/mm/yyyy)"))

    Worksheets("calend").Cells.ClearContents
    ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")

    For Each compte In OLApp.Session.Accounts

        If compte.AccountType = olExchange Then

            'stockage rdvs du compte microsoft Exchange
            For Each dossier In OLApp.Session.Folders(compte.DisplayName).Folders
                If dossier.DefaultItemType = olAppointmentItem Then
                    Set calendrier = dossier
                    GoSub Stockage_rdvts
                    Exit For
                End If
            Next dossier

            'stockage rdvs des calendriers partagés avec le compte microsoft Exchange
            Set récipient = OLApp.Session.CreateRecipient(compte.DisplayName)
            Set calendriers_partagés = OLApp.Session.GetSharedDefaultFolder(récipient, olFolderCalendar)
            For Each calendrier In calendriers_partagés.Folders
                GoSub Stockage_rdvts
            Next calendrier
        End If

    Next compte

    'remplissage de la feuille à partir des rdvs stockés
    If UBound(myArr) > -1 Then ws.Range("A2").Resize(UBound(myArr) + 1, 5).Value = Application.Index(myArr, 0, 0) _
    Else MsgBox "no appointment found"

    'AutoFit
    ws.Columns.AutoFit
    Set OLApp = Nothing
    On Error GoTo 0

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

Stockage_rdvts:
    'filtrage des rdvs correspondant à la fourchette de dates
    filtre = "[Start] > '" & FromDate & "'" & "And" & "[Start] < '" & ToDate + 1 & "'"
    Set rdvts_trouvés = calendrier.Items.Restrict(filtre)
    rdvts_trouvés.Sort "[Start]"

    'analyse des rdvts trouvés
    For Each olApt In rdvts_trouvés
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
            ReDim Preserve myArr(NextRow)
            ref_calendrier = calendrier.Parent.Name & "-" & calendrier.Name
            myArr(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, ref_calendrier)
            NextRow = NextRow + 1
        End If
    Next olApt

    Return

ErrHand:
    'Add error handler
    MsgBox "Erreur traitement " & Err.Description
    Resume cleanExit
End Sub

Bonsoir,

Merci pour votre réponse.

Je viens de tester la macro, mais à nouveau seul mon calendrier s'importe sur la feuille.

Ce que je ne m'explique pas c'est que je parviens, comme je vous l'ai dit à importer individuellement avec la dernière macro que je vous ai présentée plus haut.

Autre petit détail les dates s'inversent entre le mois et le jour.

Quand je fais un Debug, seuls s'affichent :

Attente
Boîte de réception
Boîte d'envoi
Brouillons
Calendrier

Quand je liste les calendriers partagés avec la macro ci-dessous, j'obtiens bien tous les noms des personnes qui partages leur calendrier dans Calendrier partagés

Sub ListSharedCalendars()
    Dim objExpCal As Outlook.Explorer
    Dim objNavMod As Outlook.CalendarModule
    Dim objNavGroup As Outlook.NavigationGroup
    Dim objNavFolder As Outlook.NavigationFolder
    Dim objFolder As Outlook.Folder
    Set objExpCal = Session.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
    For Each objNavFolder In objNavGroup.NavigationFolders
        Debug.Print objNavFolder.DisplayName
    Next
    Set objNavMod = Nothing
    Set objNavGroup = Nothing
    Set objNavFolder = Nothing
    Set objFolder = Nothing
End Sub

Avec code, vous récupérez effectivement tous les calendriers présents dans Outlook.

Je pense qu'il y a ambiguïté sur le mot "calendrier partagé". Mon code correspond aux calendriers qui ont été partagés avec votre compte Microsoft présent dans Outllook. Autrement dit, une action de partage a été effectué sur les calendriers de vos personnes et envoyée à l'adresse de votre compte Microsoft.

Les calendriers de vos personnes ont dû être ajoutés différemment, sans doute via la fonction "ajouter calendrier" disponible dans Outlook.

Bonjour,

Les personnes ont ajouté le partage de leur calendrier via la fenêtre de "propriété Calendrier" en ajoutant mon nom dans les autorisations d'accès avec une lecture.

Je viens de faire l'essai avec un partage de calendrier reçu par mail, mais la conclusion est la même, les données ne s'affichent pas.

Quelle est la procédure dont vous parlez pour le partage ?

Bonne journée

Déjà nous avons une différence de version : Office 2010 pour vous, Office 2021 pour moi.

Ensuite, connectez -vous à votre compte Microsoft sur le Web et choisissez l'application calendrier. Si les calendriers des personnes ont bien été partagés avec votre compte, vous devez les voir apparaître dans le groupe "autres calendriers".

Vous y avez l'option de partager votre calendrier avec d'autres personnes. C'est la procédure que j'ai suivie et les calendriers partagés se sont retrouvés dans mon Outlook.

Bonjour,

Tout d'abord je vous remercie.

J'ai testé votre solution sans succès.

La seul macro qui fonctionne est la macro ci-dessous, mais elle me permets seulement de requêter un calendrier partagé à la fois.

Pensez-vous qu'il est possible de créer un boucle dont les calendriers seraient alimentés par un liste ?

Merci.

Option Explicit

Public Sub ListAppointments()
On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9

    Dim OLApp       As Object: Set OLApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = OLApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olFolder2    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
    Dim objOwner2   As Object: Set objOwner2 = olNS.CreateRecipient("pierre.dupont@dom.fr")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = InputBox("Enter the start date (format: dd/mm/yyyy)")
   ToDate = InputBox("Enter the end date(format: dd/mm/yyyy)")

    objOwner.Resolve
    objOwner2.Resolve

    If (objOwner.Resolved And objOwner2.Resolve) Then
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
        Set olFolder2 = olNS.GetSharedDefaultFolder(objOwner2, olFolderCalendar)
        'Set olFolder = olNS.GetSharedDefaultFolder(9)
    End If
    Worksheets("calend").Cells.ClearContents
    ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")

    'Ensure there at least 1 item to continue
    Debug.Print olFolder.Items.Count
    Debug.Print objOwner.Name
    Debug.Print objOwner2.Name

    If (olFolder.Items.Count = 0 And olFolder2.Items.Count = 0) Then Exit Sub

    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 4, 0 To olFolder.Items.Count - 1)

    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next

    For Each olApt In olFolder.Items
    If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
    If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then

        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        myArr(4, NextRow) = objOwner.Name
        NextRow = NextRow + 1
        Else
        End If
        End If
    Next olApt
     Set olApt = Nothing
        Set olFolder = Nothing
        Set olNS = Nothing
        Set OLApp = Nothing
    On Error GoTo 0

    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:E" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

    'AutoFit
    ws.Columns.AutoFit

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrHand:
    'Add error handler
    Resume cleanExit
End Sub

ci-dessous un code qui liste les rendez-vous pour tous vos calendriers

Sub lister_rdvs()
    'Constantes Outlook
    Const olCalendarModule = 159
    Const olFolderInbox As Byte = 6
    Const olMinimized As Byte = 1

    'Variables Outlook
    Dim OLApp As Object, OLExp As Object
    Dim module As NavigationModule
    Dim module_calendrier As CalendarModule
    Dim groupe_calendriers As NavigationGroup
    Dim calendrier_dossier As NavigationFolder
    Dim calendrier As folder
    Dim filtre As String, ref_calendrier As String
    Dim rdvts_trouvés As Object, olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date, ToDate As Date
    Dim tb(): tb = Array("")

    '// assignation application Outlook et explorateur
    Set OLApp = CreateObject("Outlook.Application")

    ' si OutLook n'est pas ouvert .....................
    If OLApp.Explorers.Count = 0 Then
        OLApp.Session.GetDefaultFolder(olFolderInbox).Display
        OLApp.ActiveExplorer.WindowState = olMinimized
    End If
    ' .....................................................
    Set OLExp = OLApp.ActiveExplorer

    '// assignation fourchette de dates
    FromDate = CDate(InputBox("Date de début (format: dd/mm/yyyy)"))
    ToDate = CDate(InputBox("Date de fin(format: dd/mm/yyyy)"))

'// initialisation feuille "Calend"
    With ThisWorkbook.Sheets("calend")
        .Cells.ClearContents
        .Columns("B:C").NumberFormat = "m/d/yyyy"
        .Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")
    End With

    '// exploration des calendriers
    For Each module In OLExp.NavigationPane.Modules

        If module.Class = olCalendarModule Then
            For Each groupe_calendriers In module.NavigationGroups

                For Each calendrier_dossier In groupe_calendriers.NavigationFolders
                    'assignation du calendrier
                    Set calendrier = calendrier_dossier.folder
                    'stockage rdvs du calendrier
                    GoSub Stockage_rdvts
                Next calendrier_dossier

            Next groupe_calendriers
            Exit For
        End If

    Next module

    '// remplissage de la feuille à partir des rdvs stockés
    With ThisWorkbook.Sheets("calend")
        If UBound(tb) > -1 Then .Range("A2").Resize(UBound(tb) + 1, 5).Value = Application.Index(tb, 0, 0) _
        Else MsgBox "pas de rdvts trouvés"
    End With

    '// sortie procédure
    Exit Sub

'// sous_procédure de stockage des rdvts dans un tableau selon filtre de dates
Stockage_rdvts:
    'filtrage des rdvs correspondant à la fourchette de dates
    filtre = "[Start] > '" & FromDate & "'" & "And" & "[Start] < '" & ToDate + 1 & "'"
    Set rdvts_trouvés = calendrier.Items.Restrict(filtre)
    rdvts_trouvés.Sort "[Start]"

    'analyse des rdvts trouvés
    For Each olApt In rdvts_trouvés
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
            ReDim Preserve tb(NextRow)
            ref_calendrier = calendrier.Name & "-" & calendrier.store.DisplayName
            tb(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, ref_calendrier)
            NextRow = NextRow + 1
        End If
    Next olApt

    Return

End Sub

J'ai une erreur d'indice d'exécution 9 à la ligne :

ref_calendrier = calendrier.Name & "-" & Split(calendrier.FolderPath, "\")(2)

Ajouter les constantes Outlook

Sub lister_rdvs()
    'Constantes Outlook
    Const olCalendarModule = 159
    Const olFolderInbox As Byte = 6
    Const olMinimized As Byte = 1

    'Variables Outlook
    'Variables Outlook
    Dim OLApp As Object, OLExp As Object

Si ça ne marche pas, remplacer l'instruction par :

ref_calendrier = calendrier.Parent.Name & "-" & calendrier.Name

A présent il semble que cela fonctionne, hormis le nom des calendriers.

J'obtiens "-calendrier" sans avoir le nom du calendrier du propriétaire du calendrier partagé.

Aussi, j'ai toujours le problème de l'inversion jour/mois dans les dates.

Merci à vous.

J'obtiens "-calendrier" sans avoir le nom du calendrier du propriétaire du calendrier partagé.

Après l'instruction

ref_calendrier = calendrier.Parent.Name & "-" & calendrier.Name

Faites un Debug

Debug.Print calendrier.FolderPath

et communiquez les résultat obtenus

Aussi, j'ai toujours le problème de l'inversion jour/mois dans les dates.

insérer une instruction de formatage de date dans ce groupe d'instructions :

    '// initialisation feuille "Calend"
    With ThisWorkbook.Sheets("calend")
        .Cells.ClearContents
        .Columns("B:C").NumberFormat = "m/d/yyyy"
        .Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")
    End With