export du carnet d'adresse avec la date du dernier message reçu

Sub Importercontacts()
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.Namespace
    Dim Dossier As Outlook.MAPIFolder
    Set Ns = Ol.GetNamespace("MAPI")
    Set Dossier = Ns.Folders(1)
    SearchFolders Dossier
    x = 0
    ThisWorkbook.Save
    MsgBox "terminé !"
End Sub
Private Sub SearchFolders(ByVal Fld As Outlook.MAPIFolder)
    Application.ScreenUpdating = False
    Dim y As Integer
    Dim OLmail 'As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment
    Dim SousDossier As Outlook.MAPIFolder
    On Error Resume Next
    ligne = 2
    For Each SousDossier In Fld.Folders
        If SousDossier.DefaultItemType = 0 Then
            For Each OLmail In SousDossier.Items
                Cells(ligne, 1) = OLmail.SenderName
                Cells(ligne, 2) = OLmail.SenderEmailAddress
                Cells(ligne, 3) = OLmail.ReceivedTime
                Cells(ligne, 4) = OLmail.To
                If Range("objet") Then Cells(ligne, 5) = OLmail.Subject
                ligne = ligne + 1
                DoEvents
            Next OLmail
        End If
        SearchFolders SousDossier
    Next SousDossier
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub