Sub Telefonliste()
On Error Resume Next
 
Const olFolderContacts = 10
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
 
Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items
 
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
Set objWorksheet = objWorkbook.Worksheets(1)
 
objExcel.Cells(1, 1) = "Name"
objExcel.Cells(1, 2) = "Telefonummer"
 
I = 2
 
For Each ObjContact In colContacts
If Not ObjContact.BusinessTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.BusinessTelephoneNumber
I = I + 1
End If
 
If Not ObjContact.MobileTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.MobileTelephoneNumber
I = I + 1
End If
 
If Not ObjContact.HomeTelephoneNumber = "" Then
objExcel.Cells(I, 1).Value = ObjContact.FullName
objExcel.Cells(I, 2).Value = ObjContact.HomeTelephoneNumber
I = I + 1
End If
Next
 
Set objRange = objWorksheet.UsedRange
objRange.EntireColumn.Autofit
End Sub