Option Explicit 
Const CdoAddressListGAL = 0 
Const CdoUser = 0 
Const CdoRemoteUser = 6 
#Const EarlyBind = True 
 
Sub GetGAL() 
     'Requires Excel 2000 as it uses Array
     
    Dim X As Variant, CDOList As Variant, TitleList As Variant, CDOitem As Variant 
    Dim NumX As Long, ArrayDump As Long, i As Long, v As Long, u As Long 
     
     'Change the #Const to True to enable Early Binding
     
    #If EarlyBind Then 
        Dim objSession As MAPI.Session, oFolder As MAPI.AddressList, oMessage As MAPI.AddressEntry 
        Set objSession = New MAPI.Session 
        CDOList = Array(CdoPR_DISPLAY_NAME, CdoPR_GIVEN_NAME, CdoPR_SURNAME, 972947486, CdoPR_ACCOUNT, _ 
        CdoPR_TITLE, CdoPR_OFFICE_TELEPHONE_NUMBER, CdoPR_MOBILE_TELEPHONE_NUMBER, CdoPR_PRIMARY_FAX_NUMBER, _ 
        CdoPR_COMPANY_NAME, CdoPR_DEPARTMENT_NAME, 974716958, CdoPR_STREET_ADDRESS, _ 
        CdoPR_LOCALITY, CdoPR_STATE_OR_PROVINCE, CdoPR_COUNTRY, _ 
        CdoPR_ASSISTANT, CdoPR_ASSISTANT_TELEPHONE_NUMBER) 
    #Else 
        Dim objSession As Object, oFolder As Object, oMessage As Object 
        Set objSession = CreateObject("MAPI.Session") 
        CDOList = Array(805371934, 973471774, 974192670, 972947486, 973078558, 974585886, _ 
        973602846, 974913566, 975372318, 974520350, 974651422, 974716958, 975765534, _ 
        975634462, 975699998, 975568926, 976224286, 976093214) 
    #End If 
     
    With objSession 
        .Logon , , False, False 
        Set oFolder = .GetAddressList(CdoAddressListGAL) 
    End With 
     
    TitleList = Array("GAL Name", "Given Name", "Surname", "Email address", "Logon", "Title Field", _ 
    "Telephone", "Mobile", "Fax", "CSG/Group", "Department", "Site", "Address", "Location", "State ", _ 
    "Country Field", "Assistant Name", "Assistant Phone") 
     
     'Grab 2000 records in one hit before writing to sheet
     
    ArrayDump = 2000 
    Cells.Clear 
     
     'Add Titles
    With Range("A1").Resize(1, UBound(TitleList) + 1) 
        .Formula = TitleList 
        .HorizontalAlignment = xlCenter 
        .Interior.ColorIndex = 35 
        .Font.Bold = True 
        .Font.Size = 12 
    End With 
     
    ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1) 
     
    On Error Resume Next 
     'Some fields may not exist
     
     'Turn off screen updating
    Application.ScreenUpdating = False 
    For Each oMessage In oFolder.AddressEntries 
         
        Select Case oMessage.DisplayType 
        Case CdoUser, CdoRemoteUser 
            i = i + 1 
             'Reset variant array every after each group of records
            If i Mod (ArrayDump + 1) = 0 Then 
                 
                 'Check that records do notexceed one sheet
                If NumX * ArrayDump + i > 65535 Then 
                    MsgBox "GAL exceeds 65535 entries - extraction stopped ", vbCritical + vbOKOnly 
                    GoTo FastExit 
                End If 
                 
                 'Dump data
                NumX = NumX + 1 
                Range("A2").Offset((NumX - 1) * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X 
                ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1) 
                 
                i = 1 
            End If 
             'Display status to user
            If i Mod ArrayDump = 0 Then 
                Application.StatusBar = "Entry " & i + u + NumX * ArrayDump & " of " & oFolder.AddressEntries.Count 
                DoEvents 
            End If 
             
            v = 0 
             ' Add detail to each address
            For Each CDOitem In CDOList 
                v = v + 1 
                X(i, v) = oMessage.Fields(CDOitem) 
            Next 
        Case Else 
            u = u + 1 
        End Select 
    Next 
     
     'dump remaining entries
    Range("A2").Offset(NumX * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X 
     
     'cleanup
FastExit: 
    ActiveSheet.UsedRange.EntireRow.WrapText = False 
    Cells.EntireColumn.AutoFit 
     
    Application.StatusBar = "" 
    Application.ScreenUpdating = True 
     
    Set oFolder = Nothing 
    Set objSession = Nothing 
     
End Sub