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