Sub LectureContacts()
Set olApp = CreateObject("Outlook.Application")
Set olns = olApp.GetNamespace("MAPI")
Set olfFolder = olns.GetDefaultFolder(10)
ligne = 3
On Error Resume Next ' contacts incomplets
For Each i In olfFolder.Items
Cells(ligne, 1) = i.CompanyName '=Société
Cells(ligne, 2) = i.LastName
Cells(ligne, 3) = i.Email1Address
Cells(ligne, 4) = i.Categories
ligne = ligne + 1
Next i
On Error GoTo 0
[A2].Sort Key1:=[A2], Header:=xlYes
End Sub