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

[Excel Fox]

Hi showtime,

Welcome to ExcelFox. Code below. If you want the working file, check out the attachment.

Option Explicit

Sub GetExchangeUserDetailsFromAlias()
    
    Dim str As String
    Dim olApp As Object 'Outlook.Application
    Dim olNameSpace As Object 'Outlook.Namespace
    Dim olRecipient As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim arrUsers(1 To 65000, 1 To 3) As String
    Dim lngUser As Long
    Dim rngAlias As Range, rngAliasList As Range
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set olNameSpace = olApp.GetNamespace("MAPI")
    
    With Worksheets("Users")
        Set rngAliasList = .Range("rngAliasList")
    End With
    For Each rngAlias In rngAliasList
        lngUser = lngUser + 1
        If Len(rngAlias.Value) > 0 Then
            str = rngAlias.Value
            Set olRecipient = olNameSpace.CreateRecipient(str)
            olRecipient.Resolve
            If olRecipient.Resolved Then
                If olRecipient.AddressEntry.AddressEntryUserType = 0 Then 'olExchangeUserAddressEntry
                    Set oEU = olRecipient.AddressEntry.GetExchangeUser
                    If Not (oEU Is Nothing) Then
                        With oEU
                            arrUsers(lngUser, 1) = .PrimarySmtpAddress
                            arrUsers(lngUser, 2) = .Name
                            arrUsers(lngUser, 3) = .MobileTelephoneNumber
                        End With
                    End If
                End If
            End If
        End If
    Next rngAlias
    rngAliasList.Offset(, 1).Resize(, 3).Value = arrUsers
    
    Set olApp = Nothing 'Outlook.Application
    Set olNameSpace = Nothing 'Outlook.Namespace
    Set olRecipient = Nothing 'Outlook.Recipient
    Set oEU = Nothing 'Outlook.ExchangeUser
    If lngUser Then Erase arrUsers
    Set rngAlias = Nothing
    Set rngAliasList = Nothing
    
End Sub

[showtime]

Wow! This is awesome and it works like a charm. Thank you so much!!!

[showtime]

I detected a small issue with the code - it returns #N/A for the three extracted fields/columns from row 65,0001 to the last row of the worksheet.

Also would appreciate if you can make these small modifications:

1) Add a header for each column of the three fields such as Email, Name and Phone Number.
2) Some emails comes like joe.smith@outlook.com (there is always a period between the first and last name) and would like to capitalize the "J"and "S", some are already come in correct form so those shouldn't change.
3) The Name column comes like Smith, Joe G. (ABC Company) - is it possible to separate Joe (first name) G. (middle name) and Smith (last name) in separate columns with the appropriate headers? Code should disregard the (ABC Company)....it's always in this format "(company name)". Some people don't have a middle name so it should be blank in that column.

Thanks!!

[showtime]

The #NA from row 65,001 to end of the worksheet should be blank since there is no alias listed in the adjacent column A. Just wanted to clarify that.

[showtime]

Hi showtime,

Welcome to ExcelFox. Code below. If you want the working file, check out the attachment.

Option Explicit

Sub GetExchangeUserDetailsFromAlias()
    
    Dim str As String
    Dim olApp As Object 'Outlook.Application
    Dim olNameSpace As Object 'Outlook.Namespace
    Dim olRecipient As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim arrUsers(1 To 65000, 1 To 3) As String
    Dim lngUser As Long
    Dim rngAlias As Range, rngAliasList As Range
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set olNameSpace = olApp.GetNamespace("MAPI")
    
    With Worksheets("Users")
        Set rngAliasList = .Range("rngAliasList")
    End With
    For Each rngAlias In rngAliasList
        lngUser = lngUser + 1
        If Len(rngAlias.Value) > 0 Then
            str = rngAlias.Value
            Set olRecipient = olNameSpace.CreateRecipient(str)
            olRecipient.Resolve
            If olRecipient.Resolved Then
                If olRecipient.AddressEntry.AddressEntryUserType = 0 Then 'olExchangeUserAddressEntry
                    Set oEU = olRecipient.AddressEntry.GetExchangeUser
                    If Not (oEU Is Nothing) Then
                        With oEU
                            arrUsers(lngUser, 1) = .PrimarySmtpAddress
                            arrUsers(lngUser, 2) = .Name
                            arrUsers(lngUser, 3) = .MobileTelephoneNumber
                        End With
                    End If
                End If
            End If
        End If
    Next rngAlias
    rngAliasList.Offset(, 1).Resize(, 3).Value = arrUsers
    
    Set olApp = Nothing 'Outlook.Application
    Set olNameSpace = Nothing 'Outlook.Namespace
    Set olRecipient = Nothing 'Outlook.Recipient
    Set oEU = Nothing 'Outlook.ExchangeUser
    If lngUser Then Erase arrUsers
    Set rngAlias = Nothing
    Set rngAliasList = Nothing
    
End Sub

Can you help remove the error that I detected with the code and if possible make those small modifications? You can skip or make # 3 optional (by adding the code as a comment). Thank you

[hickeyma]

This is exactly what I was looking for but it stops returning data after the first 3 rows, how would I modify to lookup like 30+ lines?

Hi showtime,

Welcome to ExcelFox. Code below. If you want the working file, check out the attachment.

Option Explicit

Sub GetExchangeUserDetailsFromAlias()
    
    Dim str As String
    Dim olApp As Object 'Outlook.Application
    Dim olNameSpace As Object 'Outlook.Namespace
    Dim olRecipient As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim arrUsers(1 To 65000, 1 To 3) As String
    Dim lngUser As Long
    Dim rngAlias As Range, rngAliasList As Range
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set olNameSpace = olApp.GetNamespace("MAPI")
    
    With Worksheets("Users")
        Set rngAliasList = .Range("rngAliasList")
    End With
    For Each rngAlias In rngAliasList
        lngUser = lngUser + 1
        If Len(rngAlias.Value) > 0 Then
            str = rngAlias.Value
            Set olRecipient = olNameSpace.CreateRecipient(str)
            olRecipient.Resolve
            If olRecipient.Resolved Then
                If olRecipient.AddressEntry.AddressEntryUserType = 0 Then 'olExchangeUserAddressEntry
                    Set oEU = olRecipient.AddressEntry.GetExchangeUser
                    If Not (oEU Is Nothing) Then
                        With oEU
                            arrUsers(lngUser, 1) = .PrimarySmtpAddress
                            arrUsers(lngUser, 2) = .Name
                            arrUsers(lngUser, 3) = .MobileTelephoneNumber
                        End With
                    End If
                End If
            End If
        End If
    Next rngAlias
    rngAliasList.Offset(, 1).Resize(, 3).Value = arrUsers
    
    Set olApp = Nothing 'Outlook.Application
    Set olNameSpace = Nothing 'Outlook.Namespace
    Set olRecipient = Nothing 'Outlook.Recipient
    Set oEU = Nothing 'Outlook.ExchangeUser
    If lngUser Then Erase arrUsers
    Set rngAlias = Nothing
    Set rngAliasList = Nothing
    
End Sub

[kirin999]

You can use the following VBA code to extract Outlook GAL email addresses using aliases for multiple rows:

Sub GetExchangeUserDetailsFromAlias()
    
    Dim str As String
    Dim olApp As Object 'Outlook.Application