Active Directoryでフルネームに基づいてDepartment of userを取得

Question

Excelのフルネームのユーザーのリストがあります。 ADから取得することで、フルネームに基づいて部門を自動的に取得したいと考えています。

マイシートTabelle1には、700人以上のユーザーのリストがあります。この場合、時間を節約するために自動的に実行する必要があります。

基本的に、私は彼らのフルネームに基づいて広告を見たいと思っています。 ADユーザでフルネームが一致した場合は、7列目に部門が配置されます。

私はコードを見つけましたが、私は私が続けることができる方法で確認していない：

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

あなたは単に一致するユーザー名のレコードを取得するには、クエリにフィルタを使用することができます。

---

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