Option Explicit
Dim objRoot 'объект для привязки к корню AD
Dim objGroups 'коллекция экземпляров класса "Группа безопасности", членом которых пользователь является непосредственно
Dim objGroup 'экземпляр класса "Группа безопасности"
Dim strDomain 'имя домена в форматах (последовательно): NetBIOS, RDN
Dim strDC 'имя контроллера домена в формате NetBIOS
Dim strUser 'имя пользователя, для котрого определяется членство в группах
            '(предполагается соответствие значению атрибута "Common-Name")
Dim objWsNet 'экземпляр класса "WScript.Network"
Dim objWMI 'объект для привязки к WMI-пространству, содержащему классы "Win32_UserAccount" и "Win32_GroupUser"
Dim objCollection, objItem, intNumber 'коллекция, экземпляр, кол-во экземпляров (соответственно) класса "Win32_UserAccount"
Dim objConnection, objCommand, objRSet 'объекты для получения списка групп безопасности с помощью ADO
Dim strCommandText 'текст запроса к AD с помощью ADO
Dim strPath, strTemp, arrTemp 'вспомогательные переменные
Dim blnHasResult 'флаг-признак прекращения итерационного просмотра
                 '(просмотр прекращается, если на текущем шаге итерации не найдено ни одной группы,
                 'членом которой пользователь был бы косвенно)
Dim strList 'итоговый список групп, членом которых является пользователь

'экземпляры класса "Scripting.Dictionary"
Dim dictResPositive 'уточняемый на каждом шаге итерации список групп, членом которых пользователь ЯВЛЯЕТСЯ
Dim dictResNegative 'уточняемый на каждом шаге итерации список групп, членом которых пользователь НЕ ЯВЛЯЕТСЯ
Dim dictTemp 'список групп, для которых на текущем шаге итерации проверяется косвенное членство пользователя

Const ADS_SCOPE_SUBTREE = 2 'флаг-признак, указывающий область просмотра дерева AD (всё дерево полностью)

strUser = Trim(InputBox("Имя пользователя:"))
If Len(strUser) > 0 Then
    Set objWsNet = CreateObject("WScript.Network")
    strDomain = objWsNet.UserDomain
    Set objWsNet = Nothing
    Set objRoot = GetObject("LDAP://RootDSE")
    strDC = objRoot.Get("dnsHostName")
    On Error Resume Next
    Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strDC & "\root\cimv2")
    If Err.Number = 0 Then
        Set objCollection = objWMI.ExecQuery("SELECT * FROM Win32_UserAccount WHERE Domain='" & strDomain & "' AND Name='" & strUser & "'")
        intNumber = objCollection.Count
        If intNumber > 0 Then
            Set dictResPositive = CreateObject("Scripting.Dictionary")
            dictResPositive.CompareMode = 1
            Set dictResNegative = CreateObject("Scripting.Dictionary")
            dictResNegative.CompareMode = 1
            Set dictTemp = CreateObject("Scripting.Dictionary")
            dictTemp.CompareMode = 1
            'WScript.Echo "Ищем группы явного членства пользователя."
            For Each objItem In objCollection
                Set objGroups = objWMI.ExecQuery("ASSOCIATORS OF {Win32_UserAccount.Domain='" & strDomain & _
                                "',Name='" & strUser & "'} WHERE AssocClass=Win32_GroupUser")
                If objGroups.Count > 0 Then
                    For Each objGroup In objGroups
                        dictResPositive.Add objGroup.Name, True
                        'WScript.Echo "Пользователь - явный член группы " & objGroup.Name
                    Next
                End If
                Set objGroups = Nothing
            Next
            Set objItem = Nothing
            strDomain = objRoot.Get("DefaultNamingContext")
            Set objConnection = CreateObject("ADODB.Connection")
            objConnection.Provider = "ADsDSOObject"
            objConnection.Open "Active Directory Provider"
            Set objCommand = CreateObject("ADODB.Command")
            Set objCommand.ActiveConnection = objConnection
            objCommand.Properties("Page Size") = 1000
            objCommand.Properties("Timeout") = 30
            objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
            strCommandText = "SELECT ADsPath,cn FROM 'LDAP://" & strDomain & "' WHERE objectCategory='Group'"
            objCommand.CommandText = strCommandText
            Set objRSet = objCommand.Execute
            objRSet.MoveFirst
            Do
                strPath = objRSet.Fields("ADsPath").Value
                If dictResPositive.Exists(objRSet.Fields("cn").Value) Then
                    dictTemp.Add strPath, vbNull
                    'WScript.Echo "[ + ] " & strPath
                Else
                    dictResNegative.Add strPath, False
                    'WScript.Echo "[ - ] " & strPath
                End If
                objRSet.MoveNext
            Loop While Not objRSet.EOF
            Set objRSet = Nothing
            Set objCommand = Nothing
            objConnection.Close
            Set objConnection = Nothing
            'WScript.Echo vbNewLine & "Ищем группы косвенного членства пользователя."
            Do
                blnHasResult = False
                For Each strPath In dictResNegative.Keys
                    Set objGroup = GetObject(strPath)
                    'WScript.Echo "[ ? ] " & strPath
                    For Each strTemp In dictTemp.Keys
                        If objGroup.IsMember(strTemp) Then
                            dictResNegative.Item(strPath) = True
                            If Not blnHasResult Then blnHasResult = True
                        End If
                    Next
                Next
                If blnHasResult Then
                    dictTemp.RemoveAll
                    For Each strPath In dictResNegative.Keys
                        If dictResNegative.Item(strPath) Then
                            dictResPositive.Add strPath, False
                            dictTemp.Add strPath, vbNull
                            dictResNegative.Remove strPath
                            'WScript.Echo "[ + ] " & strPath
                        End If
                    Next
                End If
            Loop While blnHasResult
            Set objGroup = Nothing
            For Each strTemp In dictResPositive.Keys
                If dictResPositive.Item(strTemp) Then
                    strList = strList & strTemp & vbNewLine
                Else
                    arrTemp = Split(strTemp, ",")
                    strList = strList & Mid(arrTemp(0), 11) & vbNewLine
                    Erase arrTemp
                End If
            Next
            dictResPositive.RemoveAll
            dictResNegative.RemoveAll
            dictTemp.RemoveAll
            Set dictResPositive = Nothing
            Set dictResNegative = Nothing
            Set dictTemp = Nothing
            WScript.Echo "Итоговый список:" & vbNewLine & "===" & vbNewLine & strList
        Else
            WScript.Echo "Учётная запись " & UCase(strDomain & "\" & strUser) & " не обнаружена."
        End If
        Set objCollection = Nothing
    Else
        WScript.Echo "Ошибка подключения к контроллеру " & UCase(strDC) & ": " & Err.Description
        Err.Clear
    End If
    Set objWMI = Nothing
    Set objRoot = Nothing
    On Error GoTo 0
End If
WScript.Quit 0