Extract specific user details (Email adddress, Department, City) from Username RRS feed

  • Question

  • Below code gives me details for all the users defined in gloabladdress list. I have spcecific users name and want details for them only. Can you please help to modify this code

    Sub Email_Extract()
       Dim colAL As Outlook.AddressLists
       Dim oAL As Outlook.AddressList
       Dim colAE As Outlook.AddressEntries
       Dim oAE As Outlook.AddressEntry
       Dim oExUser As Outlook.ExchangeUser
        Set colAL = Outlook.Application.Session.AddressLists
         For Each oAL In colAL
             If oAL.AddressListType = olExchangeGlobalAddressList Then
        Set colAE = oAL.AddressEntries
        n = 2
          For Each oAE In colAE
        If oAE.AddressEntryUserType = olExchangeUserAddressEntry Then
        Set oExUser = oAE.GetExchangeUser
    ThisWorkbook.Sheets("Sheet2").Cells(n, 1).Value = oExUser.Name 'User Name
    ThisWorkbook.Sheets("Sheet2").Cells(n, 2).Value = oExUser.PrimarySmtpAddress 'SMTP address
    ThisWorkbook.Sheets("Sheet2").Cells(n, 3).Value = oExUser.Alias 'Alias Name
    ThisWorkbook.Sheets("Sheet2").Cells(n, 4).Value = oExUser.Department 'Department
    'ThisWorkbook.Sheets("Sheet2").Cells(n, 5).Value = oExUser.Address 'Email ID
    ThisWorkbook.Sheets("Sheet2").Cells(n, 5).Value = oExUser.City 'City
    ThisWorkbook.Sheets("Sheet2").Cells(n, 6).Value = oExUser.OfficeLocation 'Location
    On Error Resume Next
    ThisWorkbook.Sheets("Sheet2").Cells(n, 7).Value = oExUser.Manager.Name
         n = n + 1
                       Cells(n, 1).Activate
                   End If
           End If
    End Sub

    Wednesday, July 27, 2016 3:18 PM