Macro to pull from GAL based on excel values

A

absimg

New member
Joined
May 16, 2016
Messages
13
Reaction score
0
Points
0
Hi there,

I'd like to know if its possible to create a macro/VBA code to pull certain data from the Global Address List in Outlook to Excel.
For example, column A would feature a range of employee email address and if the macro were run, it would extract the following data into the respective rows:

Department
Full Name
Company Name
BusinessNumber
Alias
MobileNumber

Any assistance will be appreciated :)
 
What version of Excel are you running, and do you have/can you install Power Query? I believe this can be done quite easily via Power Query with the Active Directory connection. With VBA it's a bit of a pain...
 
Ken Puls said:
What version of Excel are you running, and do you have/can you install Power Query? I believe this can be done quite easily via Power Query with the Active Directory connection. With VBA it's a bit of a pain...
Click to expand...

Hey Ken, I'm running Excel 2013 and do have Power Query, but it needs to be done using VBA :/
 
Ken Puls said:
What version of Excel are you running, and do you have/can you install Power Query? I believe this can be done quite easily via Power Query with the Active Directory connection. With VBA it's a bit of a pain...
Click to expand...

Sorry forgot to mention that the employee list needs to be consolidated bi-weekly
 
absimg said:
Hey Ken, I'm running Excel 2013 and do have Power Query, but it needs to be done using VBA :/
Click to expand...

Okay, no worries.

Unfortunately I'm going to have a challenge supporting this as I'm using Office 365 for my Exchange, and it doesn't seem to be playing nice with the code I've found.

There is an article on StackExchange that holds this code though:

Code: 
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 2) As String
    Dim UserIndex As Long
    Dim i As Long

    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 Len(oUser.lastname) > 0 Then
                UserIndex = UserIndex + 1
                arrUsers(UserIndex, 1) = oUser.Name
                arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress
            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

I think you'll need to also set a reference to the Microsoft Outlook x.x library for this to work though.
 
Thanks for trying! This code pulls the entire GAL into excel, whereas I need to only pull specific employee credentials based on their email adds (for access rights to certain applications)
 
Sure, but see this line:
Code: 
[COLOR=#333333]If Len(oUser.lastname) > 0 Then

That could be modified to test the criteria you're looking for. So let's say you set up a string of email addresses:

Code: 
sLastNames = "Franco,Wanyama,Perez"

Then something like this for the test...

Code: 
If Instr(1,oUser.lastname,sLastNames) > 0 Then

(I may have the oUser.lastname and sLastNames backwards as I often get the order of Instr parameters messed up)[/COLOR]
 
Trying to play around with but its not working out :/ It's either not returning results when the string of email adds are set up, or it still extracts the entire GAL :/
 
I still need it to read the 1st column (email add) and spit out the fields for those employees only. Please also excuse my lack of progress - this is my first time using VBA ever, and have had to deep-dive due to urgency of this topic.
This is the last edit that gives the required fields of all contacts.

Code: 
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


    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, oUser.LastName, sLastNames) > 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
 
Last edited by a moderator:
Ah, okay. You've haven't actually set the string to hold any names. :)

Let's try this. Right under then "Dim i As Long" line, insert this:

Code: 
Dim sEmails as String
sEmails = "bob@somedomain.com,jim@somedomain.com"

Obviously use real emails and separate each with a comma.

Then what we'll cod is change this line:
Code: 
If InStr(1, oUser.LastName, sLastNames) > 0 Then

To this
Code: 
If InStr(1, sEmails, oUser.PrimarySmtpAddress, vbTextCompare) > 0 Then

So basically, what we are doing there is this:
  • Creating (Dimensioning) a new variable (that's the Dim line)
  • Setting the sEmails variable to hold some text (that's the key part you were missing)
  • Modifying the test line to:
    • a) test the emails instead of the name
    • b) put the parameters in the correct order (I did mess it up before) and
    • c) forcing to do a text comparison, meaning that it will ignore case sensitivity

Let me know if that fixes it. (We can also read the list of names from a worksheet range if you'd like to do that, but let's get this working first.)
 
Awesome, now it works :smile:
However, will i always need to define the user email address in the code?
I have approx. 800 user emails i would need the code to return results on, which would change by a small amount each time i would need to run the macro :/
I think it would be better if we could get it to read a list of email adds in a worksheet range if possible?
 
Absolutely. Do you know how to set up a named range?

This is quick and dirty, but assuming you set up a named range called "Emails" on a Worksheet called "Control Panel", you'd modify the code to replace this:

Code: 
sEmails = "bob@somedomain.com,jim@somedomain.com"

With this:
Code: 
Dim cl as Range

For each cl in Worksheets("Control Panel").Range("Emails")
     If Len(cl.value)>0 Then
          sEmails = sEmails & ","
     Else
          'No email in cell, ignore it
     End If
Next cl

(Make sure you only replace that one line, don't nuke the Dim sEmails line)
 
Thanks - ive set up column A as the named range "Emails" and replaced the code as you mentioned. The macro runs but does not return any results even though ive included some email adds from GAL in column A. Do you know why this could be?
Thank you for your patience with all my noob questions :)
 
Okay, so I think it's time you learned some debugging steps here.

Make sure you display the Immediate window in the visual basic editor (CTRL + G)
Right after the "Next cl" line, add this:

Code: 
Debug.Print sEmails

When you run the routine, do you see a list of emails show up in the immediate window, or no?
 
Okay, so the issue is that the data is not being read from your cells. So we need to look at the range you've pointed to and what is coming up.

Can you check the address of the named range for me? To do that go to Formulas --> Name Manager. What is the cell address that it lists for Emails? And what worksheet is it on?
 
Sure the cell address and worksheet is: =Users!$A:$A (I have renamed the sheet Control Panel as Users and edited the code)
The value also lists all the emails in column A and with commas for the blank fields.
 
Okay, some code changes here:

Code: 
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 & ","
        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

So copy that in and make sure that A1 on your Users worksheet just contains a header. Your list of emails should then live in A2 and down, one email per cell.

Let me know if that works. If it doesn't, I'd like to know what the two items are that feed into the Immediate window. (For the second one, just copy up to the 3rd comma and replace your real domain with "somedomain.com".)
 
Hi Ken,

It still doesn't seem to work and the only thing displayed in the Immediate window is:

$A$2:$A$5
,,,,
 
You must log in or register to reply here.
Back
Top