Excel VBA Macro to Extract Outlook GAL Email Address Using Alias

[showtime]

Hi,

In a worksheet called "Users" I have a defined named range for column A called "Aliases" which has one text data in each cell like:

VACBHAW
VTQOBRE
POTWVYZ

I would like to lookup these aliases in the Outlook Global Address List (GAL) and pull in these three fields: emails, name, and phone number. Each alias exists in Outlook GAL, if it doesn't then it should not return anything for those three fields. Keep in mind that I have hundreds of these aliases listed in column A, so I would like the code to be fast if possible. Please note I have Office 365.

I found a similar code online, but I don't know how to modify it to fit my requirement:

Sub tgr()    
    Dim appOL As Object
    Dim oGAL As Object
    Dim oContact As Object
    Dim oUser As Object
    Dim arrUsers(1 To 65000, 1 To 7) As String
    Dim UserIndex As Long
    Dim i As Long
    Dim sEmails as String
    Dim cl as Range
    Dim rngEmails as Range


    With Worksheets("Users")
        Set rngEmails = .Range("A2:" & .Range("A" & .Rows.Count).End(xlup).Address)
    End With


    For each cl in rngEmails
        If Len(cl.value)>0 Then
            sEmails = sEmails & Cl.Value & ","
        Else
            'No email in cell, ignore it
        End If
    Next cl

    Set appOL = CreateObject("Outlook.Application")
    Set oGAL = appOL.GetNamespace("MAPI").AddressLists("Global Address List").AddressEntries

    For i = 1 To oGAL.Count
        Set oContact = oGAL.Item(i)
        If oContact.AddressEntryUserType = 0 Then
           Set oUser = oContact.GetExchangeUser
            If InStr(1, sEmails, oUser.PrimarySmtpAddress, vbTextCompare) > 0 Then
                UserIndex = UserIndex + 1
                arrUsers(UserIndex, 1) = oUser.PrimarySmtpAddress
                arrUsers(UserIndex, 2) = oUser.Department
                arrUsers(UserIndex, 3) = oUser.Name
                arrUsers(UserIndex, 4) = oUser.CompanyName
                arrUsers(UserIndex, 5) = oUser.BusinessTelephoneNumber
                arrUsers(UserIndex, 6) = oUser.Alias
                arrUsers(UserIndex, 7) = oUser.MobileTelephoneNumber
                
            End If
        End If
    Next i
    appOL.Quit
    If UserIndex > 0 Then
        Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
    End If
    Set appOL = Nothing
    Set oGAL = Nothing
    Set oContact = Nothing
    Set oUser = Nothing
    Erase arrUsers
 End Sub