Get Department of user based on Fullname in Active Directory - vba

Question

I have a list of users with full name in an excel file. I would like to automatically get their department based on their fullname by getting it from the AD.
My sheet Tabelle1 has a list of 700 plus users. In this case, I need it to be done automatically to save time.
Basically, I want to look in AD based on their full name. If their fullname matched in AD users, then in column 7, it will place the department.
I found a code but I am not sure on how I can continue:
Sub LoadUserInfo()
Dim x, objConnection, objCommand, objRecordSet, oUser, skip, disa
Dim sht As Worksheet
Dim Tabelle1 As Worksheet
' get domain
Dim oRoot
Set oRoot = GetObject("LDAP://rootDSE")
Dim sDomain
sDomain = oRoot.Get("defaultNamingContext")
Dim strLDAP
strLDAP = "LDAP://" & sDomain
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") = 100
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = "SELECT adsPath FROM '" & strLDAP & "' WHERE objectCategory='person'AND objectClass='user'"
Set objRecordSet = objCommand.Execute
x = 2
Set sht = ThisWorkbook.Worksheets("Tabelle1")
With sht
Do Until objRecordSet.EOF
Set oUser = GetObject(objRecordSet.Fields("aDSPath"))
skip = oUser.sAMAccountName
disa = oUser.AccountDisabled
If skip = .Cells(x, 5).Value Then
.Cells(x, 7) = oUser.Department
DoEvents
objRecordSet.MoveNext
Else
DoEvents
x = x + 1
objRecordSet.MoveNext
End If
Loop
End With
End Sub

Answer 1

You can simply use filter in the query to get records for the matching user name.
Sub test()
MsgBox GetDepartment("Stark", "Tony")
End Sub
Function GetDepartment(strLastName As String, strFirstName As String) As String
Dim objRoot As Object
Dim strDomain As String
Dim objConn As Object
Dim objComm As Object
Dim objRecordset As Object
Dim sFilter As String
Dim sAttribs As String
Dim sDepth As String
Dim sBase As String
Dim sQuery As String
Set objRoot = GetObject("LDAP://RootDSE")
strDomain = objRoot.Get("DefaultNamingContext")
Set objConn = CreateObject("ADODB.Connection")
Set objComm = CreateObject("ADODB.Command")
strLastName = Replace(strLastName, Space(1), "")
strFirstName = Replace(strFirstName, Space(1), "")
sFilter = "(&(objectClass=person)(objectCategory=user)(givenName=" & strFirstName & ")" & "(sn=" & strLastName & "*)" & ")"
sAttribs = "department,sAMAccountName,givenName,sn"
sDepth = "SubTree"
sBase = "<LDAP://" & strDomain & ">"
sQuery = sBase & ";" & sFilter & ";" & sAttribs & ";" & sDepth
objConn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
Set objComm.ActiveConnection = objConn
objComm.Properties("Page Size") = 40000
objComm.CommandText = sQuery
Set objRecordset = objComm.Execute
Do Until objRecordset.EOF
GetDepartment = objRecordset("department")
Exit Function
objRecordset.MoveNext
Loop
End Function