Sub OutlAddressList()
Dim lRow As Long
Dim OutlApp As Outlook.Application
Dim NameSp As NameSpace
Dim AdrLsts As AddressLists
Dim AdrLst As AddressList ' Returns the AddressEntries collection
Dim AdrEntrs As AddressEntries
Dim AdrEntr As AddressEntry
On Error Resume Next
Err.Clear
Set OutlApp = New Outlook.Application
Set NameSp = OutlApp.GetNamespace("MAPI")
' The AddressLists collection represents the root of the address book
' hierarchy for the current session. A particular AddressList object
' represents one of the available address books.
Set AdrLsts = NameSp.AddressLists
lRow = 0
For Each AdrLst In AdrLsts
Set AdrEntrs = AdrLst.AddressEntries
For Each AdrEntr In AdrEntrs
lRow = lRow + 1
Cells(lRow, 1).Value = AdrLst.Name
Cells(lRow, 2).Value = AdrEntr.Address
Next AdrEntr
Next AdrLst
' OutlApp.Quit
Set OutlApp = Nothing
If (Err.Number <> 0) Then MsgBox "Error Nr. : " & Err.Number
End Sub