Recursive find of managers

Hello flyboy54,

To better understand your problem, it would help if you attach your workbook for review. Please include some before and after examples of what you the macro to do.

Hello flyboy54,

Do want a unique list of the managers in column "D"?

Hello flyboy54,

This is how I see the table of managers and employees who are also managers

D      E       F
Alice  Fred
Barb   Martha
Betty
David
Fred   Barb
Martha
Tom    Alice   Betty

Hello flyboy54,

I didn't forget about you. The attached workbook has the macros shown below added to it. I have added a button on Sheet1 to run the macro. The managers names are listed in row 1 starting in column "D" and go to the right. The employees who are also managers are listed below each manager as in your original post. Let me know if this what you wanted.

Recursive Search Code for Managers

Option Explicit

Public Managers As Object
Public ManagersList As String

Sub SaveManagers()

    Dim Cell As Range
    Dim Employees As String
    Dim LastCell As Range
    Dim Manager As Variant
    Dim n As Long
    Dim Rng As Range
    
        If Managers Is Nothing Then
            With Sheet1
                Set Rng = .Range("A2:B2")
                Set LastCell = .Cells(Rows.Count, "A").End(xlUp)
                Set Rng = Rng.Resize(LastCell.Row - Rng.Row + 1, 2)
                
                With .Sort
                    .SortFields.Clear
                    .SortFields.Add Rng.Columns(1), xlSortOnValues, xlAscending
                    .SetRange Rng
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .Apply
                End With
            End With
            
            Set Managers = CreateObject("Scripting.Dictionary")
            Managers.CompareMode = vbTextCompare
            
            For Each Cell In Rng.Columns(1).Cells
                Manager = Application.Trim(Cell)
                If Manager <> "" Then
                    If Not Managers.Exists(Manager) Then
                        Employees = Cell.Offset(0, 1)
                        Managers.Add Manager, Employees
                    
                        n = 1
                        While Cell.Offset(n, 0) = Manager
                            Employees = Employees & "," & Cell.Offset(n, 1)
                            n = n + 1
                        Wend
                        
                        Managers(Manager) = Employees
                    End If
                End If
            Next Cell
        End If
                
End Sub

Function GetEmployeeManagers(ByVal Manager As String, Optional ByVal Employees As String)

    Dim Comma As String
    Dim Employee As Variant
    
        Comma = ""
        
        For Each Employee In Split(Managers(Manager), ",")
            If Managers.Exists(Employee) Then
                If ManagersList <> "" Then Comma = ","
                ManagersList = ManagersList & Comma & Employee
                Call GetEmployeeManagers(Employee, Employees)
            End If
        Next Employee
        
        GetEmployeeManagers = ManagersList
    
End Function

Sub ListManagers()

    Dim HeaderRow As Range
    Dim Manager As Variant
    Dim x As Variant
    
        Call SaveManagers
        Set HeaderRow = Sheet1.Range("D1").Resize(1, Managers.Count)
        HeaderRow.Columns.EntireColumn.ClearContents
        HeaderRow.Value = Managers.Keys
        
            For Each Manager In HeaderRow
                ManagersList = ""
                x = Split(GetEmployeeManagers(Manager), ",")
                If UBound(x) >= 0 Then
                    Manager.Offset(1, 0).Resize(UBound(x) + 1, 1).Value = Application.Transpose(x)
                End If
            Next Manager
    
End Sub

Hello flyboy54,

You're welcome. It was a challenging and fun project. Really good to hear it worked on the actual data with no problem.