Private Sub Test()
    Dim objOutlook As Object, objNamespace As Object, iRow&, iCount&
    iRow = Cells(Rows.Count, "A").End(xlUp).Row
    iCount = Application.Max(Range("A:A"))
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    Application.ScreenUpdating = False
    CreateArchive objNamespace.GetDefaultFolder(6), iRow, iCount '6=olFolderInbox
    CreateArchive objNamespace.GetDefaultFolder(5), iRow, iCount '5=olFolderSentMail
    objOutlook.Quit
    Application.ScreenUpdating = True
End Sub

Private Sub CreateArchive(objFolder As Object, iRow&, iCount&)
    'On Error Resume Next
    Dim objMail As Object, IdMail$
    For Each objMail In objFolder.Items
        IdMail = objMail.EntryID
        If Application.CountIf(Range("I:I"), IdMail) = 0 Then
           iRow = iRow + 1: iCount = iCount + 1
           Cells(iRow, "A") = iCount
           Cells(iRow, "B") = objMail.SenderName  '(тут выпадает почему то по ошибке в конце работы)
           Cells(iRow, "C") = objMail.SenderEmailAddress
           Cells(iRow, "D") = objFolder.Name
           Cells(iRow, "E") = objMail.CreationTime
           Cells(iRow, "F") = objMail.Subject
           Cells(iRow, "G") = "'" & IdMail 'IdMail
           'Cells(iRow, "E") = objMail.To
           'Cells(iRow, "F") = objMail.CC
           'Cells(iRow, "I") = Left(objMail.Body, 1067) 'Если тут поставить максимальное значение падает по переполнению памяти... по идее просто выводит текс заданной длины в ячейку
          
           
        End If
    Next
End Sub