Excel VBA Macro to Extract Outlook GAL Email Address Using Alias

[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]

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