Function getDefaultFolderFromUser(user, dossier As Outlook.OlDefaultFolders) As Outlook.MAPIFolder

    Dim OLApp As Outlook.Application
    If Application.Name = "Outlook" Then
        Set OLApp = Application
    Else
        Set OLApp = CreateObject("outlook.application")
    End If
    Dim nsOutlook As Outlook.Namespace
    Dim oRecipient As Outlook.Recipient
    Dim Fld As Outlook.MAPIFolder
 
    Set nsOutlook = OLApp.GetNamespace("MAPI")
    Set oRecipient = nsOutlook.CreateRecipient(user)
    oRecipient.Resolve
 
    If oRecipient.Resolved Then
        On Error Resume Next
        Set Fld = nsOutlook.GetSharedDefaultFolder(oRecipient, dossier)
        Set getDefaultFolderFromUser = Fld
        If Err Then Set getDefaultFolderFromUser = Nothing
    Else
        MsgBox user & vbCr & "User inconnu", vbCritical, "Inconnu"
    End If
End Function
Sub NouveauRDV_Calendrier()

    Dim OkApp As New Outlook.Application
    Dim Rdv As Outlook.AppointmentItem
    Dim Fld As Outlook.MAPIFolder
    Dim Date_receipt As Range
    Dim no_PO As String
        
    For i = 7 To Cells(Rows.Count, "L").End(xlUp).Row
            
        '-- affectation de la date de réception
        Set Date_receipt = Cells(i, "L")
        If Cells(i, "M") <> Empty Then Set Date_receipt = Cells(i, "M")
        
        '-- génération d'une relance selon conditions
        If IsDate(Date_receipt.Value) _
        And Date_receipt.Value > Date + 7 _
        And Date_receipt.Comment Is Nothing Then
            
            '-- détermination dossier calendrier associé au compte
            Set Fld = getDefaultFolderFromUser("compte2@compte.com", olFolderCalendar)
           
            '-- génération RDV  dans le calendrier associé au compte
            Set Rdv = Fld.Items.Add(olAppointmentItem)
            no_PO = Cells(i, "A").Value
            Call supp_rdv_existant(Fld, no_PO)
            
         With Rdv
             .MeetingStatus = olMeeting
             .Subject = "Relance commande " + Cells(i, 1).Value
             .Body = "Supplier : " & Cells(i, 3).Value & Chr(13) & "Mail : " & Cells(i, 4).Value & Chr(13) & "Phone : " & Cells(i, 5).Value & Chr(13) & "Description : " & Cells(i, 6).Value & Chr(13) & "PN : " & Cells(i, 7).Value & Chr(13) & "QTY : " & Cells(i, 10).Value & Chr(13) & Chr(13) & "Order Date : " & Cells(i, 2).Value & Chr(13) & "Date PN Requested : " & Cells(i, 12).Value & Chr(13) & "Project Deadline : " & Cells(i, 11).Value & Chr(13) & "Acknowledgementof Receipt : " & Cells(i, 13).Value
             .Location = "Supplier : " & Cells(i, 3).Value
             .Start = Cells(i, "L").Value - 7 & " 09:00"
             .Duration = 30 'minutes
             .Save
         End With
         
            '-- ajout commentaire date de relance
            Date_receipt.AddComment "Alerte pour une relance faite le " & Date
        End If
    Next
    
    Set OkApp = Nothing
    
End Sub

Sub supp_rdv_existant(calendrier, no_cde)
     Dim Rdv As Outlook.AppointmentItem
     
     For Each Rdv In calendrier.Items
        If Rdv.RequiredAttendees = no_cde Then Rdv.Delete
     Next Rdv

End Sub