On Error Resume Next 

Dim strUser 
Dim strOU 
Dim strPath 

Const OU = "OU=Пользователи" 
Const ShareFolder = "D:\Share\Персональные_папки" 

Set oShell = CreateObject("WScript.Shell") 
Set WshShell = CreateObject("WScript.Shell") 
Set FileSys = CreateObject("Scripting.FileSystemObject") 
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") 

strFilter = "(&(objectCategory=user))" 
strQuery = "<LDAP://" & OU & "," & strDNSDomain & ">;" & strFilter & ";distinguishedName"
 objCommand.CommandText = strQuery 
Set objRecordSet = objCommand.Execute 

Do Until objRecordSet.EOF 
  strDN = objRecordSet.Fields("distinguishedName") 
  Set objUser = GetObject("LDAP://" & strDN) 
  
  If objUser.AccountDisabled = False Then 
    strUser = objUser.Get("Displayname") 
    
    strOU = objUser.AdsPath 
    strOU = Right(strOU, Len(strOU) - InStr(strOU, "OU") - 2) 
    strOU = Left(strOU, InStr(strOU, ",") - 1) 
    
    Err.Clear 
    Set objGroup = GetObject("LDAP://CN=" & strOU & ",OU=Groups," & OU & "," & strDNSDomain)
     If (Err.Number = "-2147016656") Then 
      Err.Clear 
      Set objOU = GetObject("LDAP://OU=Groups," & OU & "," & strDNSDomain) 
      Set objGroup = objOU.Create("Group", "CN=" & strOU) 
      objGroup.Put "sAMAccountName", strOU 
      objGroup.Put "description", strOU 
      objGroup.SetInfo 
    End If 
    
    objGroup.Add objUser.AdsPath 
    
    strPath = ShareFolder & "\" & strOU 
    If Not FileSys.FolderExists(strPath) Then 
      Call FileSys.CreateFolder(strPath) 
      Call FileSys.CreateFolder(strPath & "\Home") 
      Call FileSys.CreateFolder(strPath & "\Pub") 
      Call WshShell.Run("cacls " & strPath & "\Pub" & " /e /g " & strOU & ":C", HIDE_WINDOW, WAIT_ON_RETURN)
     End If 
    
    strPath = strPath & "\Home\" & strUser 
    If Not FileSys.FolderExists(strPath) Then 
      Call FileSys.CreateFolder(strPath) 
      Call WshShell.Run("cacls " & strPath & " /e /g " & strUser & ":C", HIDE_WINDOW, WAIT_ON_RETURN)
     End If 
  End If 
  objRecordSet.MoveNext 
Loop