I have an excel in Colum H & I i have email addresses need to get full names.

This will look up users email addresses, and return the displayName or colour the email

>They could be Contacts or NtAccounts
Do you mean that the data may be user emails or the NT login?

Cheers

Dave

Sub GetEm()
    Dim rng1 As Range
    Dim rng2 As Range
    Dim c As Range
    Application.ScreenUpdating = False
    Set rng1 = Range([h1], Cells(Rows.Count, "H").End(xlUp))
    Set rng2 = Range([i1], Cells(Rows.Count, "i").End(xlUp))
    For Each c In rng1
        If Len(c.Value) > 0 Then
            Cells(c.Row, "M") = GetDN(c.Value)
            If Cells(c.Row, "M").Value = vbNullString Then c.Interior.Color = vbGreen
        End If
    Next
    For Each c In rng2
        If Len(c.Value) > 0 Then
            Cells(c.Row, "N") = GetDN(c.Value)
            If Cells(c.Row, "N").Value = vbNullString Then c.Interior.Color = vbGreen
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Public Function GetDN(user)

    On Error Resume Next

    Dim objConnection, objCommand, objRootDSE, strDNSDomain
    Dim strFilter, strQuery, objRecordSet, objArgs


    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOOBject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    Set objRootDSE = GetObject("LDAP://RootDSE")
    strDNSDomain = objRootDSE.Get("defaultNamingContext")
    strBAse = "<LDAP://" & strDNSDomain & ">"


    strFilter = "(&(objectCategory=person)(objectClass=user)(mail=" & user & "))"
    strAttributes = "displayName"
    strQuery = strBAse & ";" & strFilter & ";" & strAttributes & ";subtree"
    objCommand.CommandText = strQuery
    objCommand.Properties("Page Size") = 99999
    objCommand.Properties("Timeout") = 300
    objCommand.Properties("Cache Results") = False
    Set objRecordSet = objCommand.Execute
    objRecordSet.MoveFirst
    Do Until objRecordSet.EOF
        GetDN = objRecordSet.Fields("displayName")
        objRecordSet.MoveNext
    Loop
    objConnection.Close
    Set objConnection = Nothing
    Set objCommand = Nothing
    Set objRootDSE = Nothing
    Set objRecordSet = Nothing
End Function

Select allOpen in new window

Thanks
It could be a Users Nt account email or a Contact email

Does the code as is give you want you expect?

If not then I suggest we will need the likes of Rob to fine tune the output.

Cheers

Dave

I think this should work, but I can't test the proxyAddresses part, because I don't have Exchange.

Regards,

Rob.

Sub CheckIfEmailsExist2()
    Set adoCommand = CreateObject("ADODB.Command")
    Set ADOConnection = CreateObject("ADODB.Connection")
    ADOConnection.Provider = "ADsDSOObject"
    ADOConnection.Open "Active Directory Provider"
    adoCommand.ActiveConnection = ADOConnection
        
    ' Define the maximum records to return
    adoCommand.Properties("Page Size") = 100
    adoCommand.Properties("Timeout") = 30
    adoCommand.Properties("Cache Results") = False
    
    strBase = "<LDAP://DC=maroondah,DC=local>"
    
    For Each strColumn In Array("H", "I")
        For intRow = 2 To Cells(65536, strColumn).End(xlUp).Row
            strEmail = Cells(intRow, strColumn).Value
            If Trim(strEmail) <> "" Then
                ' Filter on user objects.
                strFilter = "(&(|(objectClass=user)(objectClass=contact))(|(mail=*" & strEmail & "*)(proxyaddresses=*" & strEmail & "*)))"
                ' Comma delimited list of attribute values to retrieve.
                strAttributes = "adsPath"
                ' Construct the LDAP syntax query.
                strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
                MsgBox strQuery
                adoCommand.CommandText = strQuery
                Set objRecordSet = adoCommand.Execute
                boolFound = False
                If Not objRecordSet.EOF Then boolFound = True
                While Not objRecordSet.EOF
                    MsgBox objRecordSet.Fields("adsPath").Value
                    objRecordSet.MoveNext
                Wend
                If boolFound = False Then
                    Cells(intRow, strColumn).Font.Bold = True
                Else
                    Cells(intRow, strColumn).Font.Bold = False
                End If
                objRecordSet.Close
            End If
        Next
    Next
    
    MsgBox "Done"
End Sub

Select allOpen in new window

Rob i get table does not exist
When debug goes here
 Set objRecordSet = adoCommand.Execute

First i get this
---------------------------
Microsoft Excel
---------------------------
<LDAP://DC=dev,DC=co,Dc=uk>;(&(|(objectClass=user)(objectClass=contact))(|(mail=.m.uk,
rvey@plc.com*)));adsPath;subtree
---------------------------
OK  
---------------------------

strBase needs to be correct, but it looks like it should be.  That's why you're getting Table does not exist.

Try replacing
strBase = "<LDAP://DC=domain,DC=com>"
with

Set objRootDSE = GetObject("LDAP://RootDSE")
strBase = "LDAP://" & objRootDSE.Get("defaultNamingContext") & ">"

Rob.

<Off Topic>

I'll leave this with Rob.

Both of your may find this EE Article of mine interesting,  Produce an Excel list of the attributes of all MP3 files that sit in or below the "My Music" folder

Sharath, this is from a question you asked and was answered by Kevin (zorvek) some years back.
Rob, this is the recent question I asked re retrieving the OS via WMI

Cheers

Dave

Rob
1 or more errors has occured. When debug goes here
 Set objRecordSet = adoCommand.Execute

Are you sure you have the strBase string correct?
I got the same error when I left the <> brackets off the ends...

Rob.

Yes its right
Please see attachment
Capture.JPG

Hi all,

In  ID: 31344803, I think Rob meant to put:
--------------------------
Try replacing
strBase = "<LDAP://DC=domain,DC=com>"
with

Set objRootDSE = GetObject("LDAP://RootDSE")
strBase = "<LDAP://" & objRootDSE.Get("defaultNamingContext") & ">"

--------------------------

(There was a missing "<")  HTH, Joe

Thanks now i get no error and H & I every email address is bold. it did not fetch the full name.
Hope it queries each email thats within a cell and finds the full name
I have like this
Sha@plc.com,Shar@plc.com,Shara@plc.com
all in one cell. So each between the Coma has to be considered as one email

Looking at your requirements, I think some major changes were needed... so I had to rewrite.

Please give this a shot.  It works for me, but there's a catch... I have it so that if any of the emails in the cell don't match, the whole cell turns red.  

Sub CheckEmails()
 
    Const ADS_SCOPE_SUBTREE = 2
    
    Set objRootDSE = GetObject("LDAP://rootDSE")
    strADsPath = objRootDSE.Get("defaultNamingContext")
    
    '-------------------------------------------------------------------
    '   User Variables
    '-------------------------------------------------------------------
    
    'If you have a specific OU, put it here otherwise, set to ""
    strOU = ""
    
    'EmailColumn/Display-Name-column
    arrColumns = Array("H/M", "I/N")
    
    'If you have headers, set to 2... if not, set to 1
    intRow = 1
    
    '-------------------------------------------------------------------
    
    If strOU <> "" Then
        strADsPath = "LDAP://" & strOU
    Else
        strADsPath = "LDAP://" & strADsPath
    End If
    
    Set objConnection = CreateObject("ADODB.Connection")
    Set objCommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    
    For Each strColumn In arrColumns
    
        intMyRow = intRow
    
        strColumnEmail = Split(strColumn, "/")(0)
        strColumnDisplayName = Split(strColumn, "/")(1)
    
        Do Until Cells(intMyRow, strColumnEmail).Value = ""
            
            strCellValue = ""
            strCellValue = Cells(intMyRow, strColumnEmail).Value
            
            arrEmails = Split(strCellValue, ",")
            
            strAllDisplayNames = ""
            
            For Each strEmail In arrEmails
                            
                strDisplayName = ""
          
                strQuery = "SELECT CN FROM '" & strADsPath & "' WHERE objectCategory='person' AND " & _
                    "( objectClass='user' OR objectClass='contact' ) " & _
                    "AND (mail='" & strEmail & "' OR proxyaddresses='" & strEmail & "')"
    
                objCommand.CommandText = strQuery
                        
                Set objRecordSet = objCommand.Execute
            
                If Not objRecordSet.EOF Then
                    objRecordSet.MoveFirst
                    strDisplayName = objRecordSet.Fields("CN").Value
                End If
            
                If strDisplayName = "" Then
                    Cells(intMyRow, strColumnEmail).Interior.ColorIndex = 3   'Red
                End If
                
                strAllDisplayNames = strAllDisplayNames & strDisplayName & ","
               
                objRecordSet.Close
                Set objRecordSet = Nothing
            
            Next
            
            If Right(strAllDisplayNames, 1) = "," Then strAllDisplayNames = Left(strAllDisplayNames, Len(strAllDisplayNames) - 1)
            Cells(intMyRow, strColumnDisplayName) = strAllDisplayNames
            
            intMyRow = intMyRow + 1
            
        Loop
    
    Next

End Sub

Select allOpen in new window

test.jpg

Thanks it runs perfect. But stops in row 2
Can it run till end of row of data
And
if whole cell gets red it would be difficult to find. Can we have them into 2 different colums
H to M  (M will have the names that are found)
I to N ( n will have the names that are found)
Can we have O & P with email addresses that did not get an match
So the whole issue is sorted.
Can i even get the headers in Row 1 for the 4 new colums what they mean

Thanks a lot it was an Awesome script . Did exactly what i wanted.

Thanks Rob & Dave
Any help with this
https://www.experts-exchange.com/questions/25993260/Change-data-within-xml-files-and-save-as-it-is.html

Thanks for stepping in Joe.  I'm glad this worked:
                strQuery = "SELECT CN FROM '" & strADsPath & "' WHERE objectCategory='person' AND " & _
                    "( objectClass='user' OR objectClass='contact' ) " & _
                    "AND (mail='" & strEmail & "' OR proxyaddresses='" & strEmail & "')"

I was obviously overcomplicating the query with the wildcards.

I also neglected to separate the emails in each cell. I thought there was one per cell.

Thanks again.  I'm running short of time these days, is there any chance you could help out with this one:
https://www.experts-exchange.com/questions/25856467/Check-if-every-user-has-2-X500's.html

Regards,

Rob.

Hey Rob, happy to help.  Time for me to go home, but I'll see if I can take a peek tomorrow if still needed.
Joe