Continue dump to next sheet

mrbeanyuk

Board Regular
Joined
Nov 30, 2005
Messages
213
Good morning. I have some code that extracts email addresses from an Outlook Global Address List. The contents of that list are in excess of 100,000 serials but the code only goes up to 65535 before stopping. Where I struggle is an instruction that enables the extract to continue running into the next Sheet 'Sheet2' etc. Any ideas would be gratefully received!

Code:
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 65535 records in one hit before writing to sheet
     
    ArrayDump = 65535
    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
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

Forum statistics

Threads
1,213,535
Messages
6,114,198
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top