Move list of user accounts to OU

On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("UsersList.txt", ForReading) '--- LIST OF USERNAMES
Set objOU = GetObject("LDAP://OU=UserAccounts,DC=domain,DC=com") '--- ADD YOUR PATH TO THE OU
Const ForReading = 1
Dim arrFileLines()
i = 0
Do Until objFile.AtEndOfStream
Redim Preserve arrFileLines(i)
arrFileLines(i) = objFile.ReadLine
i = i + 1
Loop
objFile.Close


For Each strLine in arrFileLines
strLDAP = GetDN(strLine)
objOU.MoveHere _
    "LDAP://" & strLDAP & "", vbNullString
Next


Function GetDN(UserID) 


      Set objConn = CreateObject("ADODB.Connection")
      objConn.Provider = "ADsDSOObject"
      objConn.Open "Active Directory Provider"
      
      Dim Base, Filter, Attr, Level, Server
      Server = "DC1" '--- NAME OF DOMAIN CONTROLLER
      
      Base = " & Server & "/DC=domain,DC=com>;" '--- ADD YOUR DOMAIN
      Filter = "(&(objectClass=user)(objectCategory=person)(samAccountName=" & UserID & "));"
      Attr = "distinguishedName;"
      Level = "SubTree"
      
      Set RecordSet = objConn.Execute(Base & Filter & Attr & Level)
      
      RecordSet.MoveFirst
      While Not RecordSet.EOF
            GetDN = RecordSet.Fields(0).Value
            RecordSet.MoveNext
      Wend 

End Function