Sub Main()
        Dim oApp As Outlook.Application
        Dim myNameSpace As Namespace
        Dim oGal As AddressList
        Dim myAddrEntries As addressEntry
        
        Set oApp = CreateObject("Outlook.Application")
        Set myNameSpace = oApp.GetNamespace("MAPI")
        Set oGal = myNameSpace.addressLists("Глобальный список адресов")
        
        Dim oEntries As Outlook.addressEntries
        Set oEntries = oGal.addressEntries
        
        Dim oEntry As Outlook.addressEntry
        Dim oLast As Outlook.addressEntry
        On Error Resume Next
        i = 1
        Set oLast = oEntries.GetLast
        Do
            Set oEntry = oEntries.Item(i)
            Cells(i, 1) = (oEntry.GetExchangeUser.PrimarySmtpAddress)
            Cells(i, 2) = (oEntry.Name)
            Cells(i, 3) = (oEntry.GetExchangeUser.FirstName)
            Cells(i, 4) = (oEntry.GetExchangeUser.LastName)
            Cells(i, 5) = (oEntry.GetExchangeUser.Department)
            Cells(i, 6) = (oEntry.GetExchangeUser.JobTitle)
            
            Set oEntry = Null
            i = i + 1
            
        Loop While oEntry <> oLast
    End Sub