Queries the Active Directory (via LDAP) for users belonging to ExampleGroup or one of its subgroups. The resulting users are written into the first Excel sheet.

GetADUsersExcel.vba

' Based on a VBA script of Jim Ward
Sub LDAPQueryDevices()
    Dim grouppaths(500) As String
    Dim groupnames(500) As String
    
    Dim headers2 As Variant
    headers2 = Array("GroupName", "Name", "Login", "DN", "Group1", "Group2")
   
    Const xlAscending = 1
    Const xlDescending = 2
    Const xlYes = 1
    
    '****
    ' set up our ADO query and excute it to find group matches
    '****
    Application.StatusBar = "Searching for Records..."
    
    Set cmd = CreateObject("ADODB.Command")
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
        
    cn.Open "Provider=ADsDSOObject;"
    
    ' LDAP_MATCHING_RULE_IN_CHAIN, see http://msdn.microsoft.com/en-us/library/aa746475%28VS.85%29.aspx
    cmd.CommandText = "SELECT adspath,cn from 'LDAP://" & getNC & _
                  "' WHERE objectClass = 'User' and 'memberof:1.2.840.113556.1.4.1941:' = 'CN=ExampleGroup,OU=Ressources - Applications and Services,OU=Groups,OU=Administration,DC=example,DC=org'"
    
    cmd.activeconnection = cn
        
    Set rs = cmd.Execute
    
    '****
    ' process the results of the query into our arrays for later
    '****
    i = 0
    While rs.EOF <> True And rs.bof <> True
        grouppaths(i) = rs.Fields("adspath").Value
        groupnames(i) = rs.Fields("cn").Value
        rs.movenext
        i = i + 1
    Wend
    
    cn.Close
    
    If i = 0 Then
        MsgBox "Nothing Found, Exiting"
        Exit Sub
    End If
    
    Application.StatusBar = "Records Found..." & i
    
    Freeze
    PrepareSheet 1, headers2
    
    '****
    ' now process each group found and extract all members
    '****
    ul = 1      'user lines
    
    Dim objuser As Object
    Application.StatusBar = "Populating Worksheets..."
    
    For j = 0 To i - 1
        Application.StatusBar = "Writing User " & j & " of " & i
    
        Set objuser = GetObject(grouppaths(j))
        Set objsheet = Worksheets(1)
        ul = ul + 1
        objsheet.Cells(ul, 1).Value = groupnames(j)
        objsheet.Cells(ul, 2).Value = objuser.Get("displayName")
        objsheet.Cells(ul, 3).Value = objuser.Get("sAMAccountName")
        objsheet.Cells(ul, 4).Value = objuser.Get("distinguishedName")
        
        groups = objuser.Get("memberOf")
        ' when there's only one group in memberOf, groups is a String, otherwise it's an Array
        objsheet.Cells(ul, 5).Value = MatchGroup(groups, "R_Type1_*")
        objsheet.Cells(ul, 6).Value = MatchGroup(groups, "R_Type2_*")
    Next
    
    sortSheet
    Unfreeze
    
    MsgBox "All Done"
End Sub

' Returns only the CN from a complete DN
Function GetCN(ByVal DN As String)
    parts = Split(DN, ",")
    GetCN = Right(parts(0), Len(parts(0)) - 3)
End Function

' Returns the CN of a matching (wildcards!) group or empty string
Function MatchGroup(groups As Variant, mask As String) As String
    If IsArray(groups) Or IsObject(groups) Then
        For Each usergroup In groups
            cn = GetCN(usergroup)
            If cn Like mask Then
                MatchGroup = cn
                Exit Function
            End If
        Next
    Else
        cn = GetCN(groups)
        If cn Like mask Then
            MatchGroup = cn
            Exit Function
        End If
    End If
    MatchGroup = ""
End Function

' Checks if on of groups is expectedCN
Function IsInGroup(groups As Variant, expectedCN As String) As Boolean
    If IsArray(groups) Or IsObject(groups) Then
        For Each usergroup In groups
            cn = GetCN(usergroup)
            If cn = expectedCN Then
                IsInGroup = True
                Exit Function
            End If
        Next
    Else
        cn = GetCN(groups)
        If cn = expectedCN Then
            IsInGroup = True
            Exit Function
        End If
    End If
    IsInGroup = False
End Function

' Turns off auto-calc and screen updates
Sub Freeze()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = True
End Sub

' Turns on auto-calc and screen updates
Sub Unfreeze()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
End Sub

Sub PrepareSheet(SheetNum As Integer, ColumnTitles As Variant)
    Application.StatusBar = "Creating Worksheet headers..."
    
    Dim Title As Variant
    Set objsheet = Worksheets(SheetNum)
    
    objsheet.Cells.Clear
    
    tc = 0
    For Each TitleText In ColumnTitles
        tc = tc + 1
        objsheet.Cells(1, tc) = TitleText
        objsheet.Cells(1, tc).Font.Bold = True
    Next
End Sub

Sub sortSheet()
    Application.StatusBar = "Sorting Worksheets..."
    
    Set objworksheet = Worksheets(1)
    objworksheet.Name = "Benutzer"
    objworksheet.Select
    
    Set objRange = objworksheet.UsedRange
    Set objRange2 = Range("C1")
    
    objRange.Sort objRange2, xlAscending, , , , , , xlYes
    ActiveSheet.UsedRange.Columns.EntireColumn.AutoFit
End Sub

Function getNC()
    Set objRoot = GetObject("LDAP://RootDSE")
    getNC = objRoot.Get("defaultNamingContext")
End Function