Need help - Found a macro on another site and works well to pull users and email address, However require more info to be pulled from global address list.
First Name,Last Name,Department,Job Title, Business Phone,Mobile Phone,Account,email Display Name and Sort by First Name and to delete any existing data from sheet tab"Data" and copy new info under headerfile.
Have attached sample file and code below
First Name,Last Name,Department,Job Title, Business Phone,Mobile Phone,Account,email Display Name and Sort by First Name and to delete any existing data from sheet tab"Data" and copy new info under headerfile.
Have attached sample file and code below
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
Last edited by a moderator:
