Fetch/Get Outlook GAL email Id details of a particular 'email account domain' (by Exchange

Hi All,

Could you please look into below situation and help me out soon:

Manual Situation: Every week, I get a huge list of User IDs (Alias) on a sheet (Sheet1, Column A), which could be more than 5000 and so on. I have to identify/ validate those users by using their contact details over 'Global Address List' (GAL) in my MS Outlook.
For above particular task, every time I have to copy around 100 User IDs (Alias) and open a new blank mail, paste them under "To..." section, then click on "Check Names" option in the Message Menu.
If we successfully identify 'name' and 'PrimarySmtpAddress' of the searched Alias/ User Id, then we have to pull the record of that user's Manager Name with Alias Id.
If any pasted Alias number does not get converted into User Names or e-mail address or unable to identify over GAL then that Alias will be marked as 'Removed Users'. This is the manual method to identify that who is still with the company and who has left.


Automation: I thought that first, if I pull all the available users' contact details as per GAL on a sheet, then apply a vlookup function from the weekly task sheet to this data, so this idea may work. That's why I have written below VBA codes to pull all the existed users' contact details as per GAL (VBA script file is also attached). Though it works, but not so smartly.

I need help your expertise for below improvement area of my VBA script:
1) How can it run so quickly? My GAL has more than 1 million User IDs/Alias numbers, so pulling every record activity takes 'n' number of hours.

2) How can we assign/ identify the correct "Global Address List" of the desired e-mail account for running the program?
For Example: I have a total of two GAL in my Outlook application due to two different e-mail IDs and their Exchange Servers. One is "testing.024@gmail.com" and another is "testing.024@yahoo.com".

Set myAddressList = OutSess.Session.AddressLists.Item(9) ' ("Global Address List") for the first 'GAL' of '@gmail.com'
Set myAddressList = OutSess.Session.AddressLists.Item(16) ' ("Global Address List") for the second 'GAL' of '@yahoo.com'

I have to access GAL only for my "testing.024@yahoo.com" account for identify User IDs/ Alias numbers, and I only know programmically that ".AddressLists.Item(16)" is located to this '@yahoo.com' account in my Outlook application, so while running my codes I have to choose the exact Item() number by clicking on many msgbox(es), but how would other employee know their exact AddressList.Item() for their '@yahoo.com' e-mail account.
The order/ sequence of accounts and their ExchangeServers and AddressList.Item() can be differ in the Outlook application of every employee who runs this VBA program. What if someone has more than two e-mail accounts, please help me to make this programmically smart by using the account details.

'Option Explicit

Sub Get_OutlookContacts_New()
' "VBA : Extract contact list from Outlook ("Global Address List")"
' To populate a list of all outlook contacts and their property details

' Working Fine...
' 1) Need to automatically assign the exact Item number of the AddressList for "@yahoo.com" email account
' 2) Need to speed up the processing

Dim objOutlook As Outlook.Application
Dim objAddressBook As Outlook.AddressList
Dim objAddressEntry As Outlook.AddressEntry
Dim lngRow As Long
Dim OutSess As Outlook.Account
Dim iCnt As Long
Dim iTtlGAL As Long, iCntGAL As Long

With Application
     .ScreenUpdating = False:       .DisplayAlerts = False
     .EnableEvents = False:         .Calculation = xlCalculationManual:                End With
     
    Set objOutlook = CreateObject("Outlook.Application")

    For iCnt = 1 To objOutlook.Session.Accounts.Count
        If MsgBox("Your e-mail account name: " & vbTab & objOutlook.Session.Accounts.Item(iCnt) & vbCrLf & _
                "This is account number: " & vbTab & iCnt & " out of " & objOutlook.Session.Accounts.Count & vbCrLf & _
                vbCrLf & _
                "Would you like to proceed with this account?", vbYesNo + vbQuestion) = vbYes Then
            
            Set OutSess = objOutlook.Session.Accounts(iCnt)
            
            With OutSess.Session
                For iLoop = 1 To .AddressLists.Count
                    If .AddressLists.Item(iLoop) = "Global Address List" Then
                        iTtlGAL = iTtlGAL + 1
                    End If
                Next iLoop
                For iLoop = 1 To .AddressLists.Count
                    If .AddressLists.Item(iLoop) = "Global Address List" Then
                        iCntGAL = iCntGAL + 1
                        If MsgBox("Item number: " & iLoop & " out of " & .AddressLists.Count & vbNewLine & _
                                 "Item name: " & .AddressLists.Item(iLoop) & vbNewLine & _
                                 "Total avaliable Address Entries: " & .AddressLists.Item(iLoop).AddressEntries.Count, vbYesNo + vbQuestion, "Note: This GAL number is " & iCntGAL & " out of " & iTtlGAL) = vbYes Then
                            
                            Set myAddressList = OutSess.Session.AddressLists.Item(iLoop)  '("Global Address List") for the second 'GAL'
                            iYes = 1
                          GoTo iNxtAcctLine:
                        End If
                    End If
                Next iLoop
            End With
        End If
    Next iCnt

iNxtAcctLine:
    If iYes <> 1 Then: Exit Sub:
    
    MsgBox "Now working with e-mail address: " & vbTab & OutSess & vbNewLine & _
            "Current Users Count: " & vbTab & vbTab & myAddressList.AddressEntries.Count, vbInformation, OutSess
    
Dim iPutRecrdOn As Long
Dim aaa As Variant
'Dim A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z As String

    With OutSess
        Sheets("Sheet1").Cells.Clear            ' Clear existing list
        On Error Resume Next
            Application.ScreenUpdating = False
            'Step through each contact and list each that has an email address
            For Each objAddressEntry In myAddressList.AddressEntries
                Application.ScreenUpdating = False
                If objAddressEntry.Address <> "" Then
                    intCounter = intCounter + 1
                    iPutRecrdOn = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
                    Application.StatusBar = "Address no. " & intCounter & ".../ " & myAddressList.AddressEntries.Count & ":     " & Format(((intCounter / myAddressList.AddressEntries.Count) * 100), "0.00") & "%   " & objAddressEntry.name   'objAddressEntry.Address
                    
                    For Each aaa In Array("@", "~")             '   ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")     ' , "1", "2", "3", "4", "5", "6", "7", "8", "9"
                        If aaa <> (UCase(Left(Trim(objAddressEntry.name), 1))) Then
                            Sheets("Sheet1").Cells(iPutRecrdOn, 1) = objAddressEntry.name
                            Sheets("Sheet1").Cells(iPutRecrdOn, 2) = objAddressEntry.GetExchangeUser.Alias
                            Sheets("Sheet1").Cells(iPutRecrdOn, 3) = objAddressEntry.GetExchangeUser.PrimarySmtpAddress
                            Sheets("Sheet1").Cells(iPutRecrdOn, 4) = objAddressEntry.GetExchangeUser.GetExchangeUserManager.LastName & ", " & objAddressEntry.GetExchangeUser.GetExchangeUserManager.FirstName
                            Sheets("Sheet1").Cells(iPutRecrdOn, 5) = objAddressEntry.GetExchangeUser.GetExchangeUserManager.Alias
'                            Sheets("Sheet1").Cells(iPutRecrdOn, 6) = objAddressEntry.GetExchangeUser.Address
'                          DoEvents
                            Exit For:
                        End If
                    Next aaa
                End If
            Next objAddressEntry
        On Error GoTo 0
        Application.StatusBar = False
    End With
    
'****************************************************************************************************
    Set objOutlook = Nothing
    Set myAddressList = Nothing
    MsgBox "Done!", vbInformation, ThisWorkbook.name
    
With Application
     .ScreenUpdating = False:       .DisplayAlerts = False
     .EnableEvents = False:         .Calculation = xlCalculationAutomatic:                End With
    
End Sub

3) Other Logic - Is there any other faster method to get this task done automatically? I don't know if my below idea is valid or not:
I think that if I sort all the User IDs/ Alias in ascending order on the excel sheet, then try to find out their contact details over GAL. If we find a record then store that position sequence/order in a variable, so the next Alias search time we do not have to search from the start in the GAL. I think that it can we save more time, do not know if it can be possible here. (I do not know this kind of programming skills for Outlook; need your help)

Thanks in advance!