- Jun 5, 2014
- Office Version
I want to extract values such as the Full Name, Alias, Phone Number etc from Outlook Global Address List (GAL) based on a range of emails I have listed in column A. The range in column A is called "Emails". I found the following code but it seems to run at an error at this line;. I'm not sure what to do. If this can be done via Power Query I would def go try that route. Appreciate any help.
sEmails = sEmails & C1.Value & ","
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 'This is for debugging only and should be removed once all is fixed Debug.Print rngEmails.Address For each cl in rngEmails If Len(cl.value)>0 Then sEmails = sEmails & C1.Value & "," Else 'No email in cell, ignore it End If Next cl 'This is for debugging only and should be removed once all is fixed Debug.Print sEmails 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