VBA Code to run hierarchy

[PJVV77]

Hi,

I need help with VBA code so that I can enter a supervisor's ID and name and then run the macro to build a complete hierarchy for that person.

Per the example below I have a list of supervisors and employees. I want to type in a supervisor's ID and name (ID "1000", Name "Person A") as o the right of the example and then need the macro to run a complete hierarchy for that person. If I did the same for "Person O" I would only see those that name and the 5 reports.

Appreciate any help!

Pieter

Supervisor ID

Supervisor Name

Person ID

Person Name

1000​

Person A

1000​

Person A

1000​

Person A

1001​

Person B

1001​

Person B

1000​

Person A

1002​

Person C

1004​

Person E

1000​

Person A

1003​

Person D

1005​

Person F

1001​

Person B

1004​

Person E

1006​

Person G

1001​

Person B

1005​

Person F

1002​

Person C

1001​

Person B

1006​

Person G

1007​

Person H

1002​

Person C

1007​

Person H

1008​

Person I

1002​

Person C

1008​

Person I

1009​

Person J

1002​

Person C

1009​

Person J

1003​

Person D

1003​

Person D

1010​

Person K

1010​

Person K

1003​

Person D

1011​

Person L

1013​

Person N

1003​

Person D

1012​

Person M

1014​

Person O

1010​

Person K

1013​

Person N

1016​

Person Q

1010​

Person K

1014​

Person O

1017​

Person R

1010​

Person K

1015​

Person P

1018​

Person S

1014​

Person O

1016​

Person Q

1019​

Person T

1014​

Person O

1017​

Person R

1020​

Person U

1014​

Person O

1018​

Person S

1015​

Person P

1014​

Person O

1019​

Person T

1011​

Person L

1014​

Person O

1020​

Person U

1012​

Person M

 

[kennypete]

Here is one solution to this. Conveniently, I needed something similar myself...serendipity!

Using your data, in a Worksheet shSource named Source:

Book1
	A	B	C	D
1	Supervisor ID	Supervisor Name	Person ID	Person Name
2			1000	Person A
3	1000	Person A	1001	Person B
4	1000	Person A	1002	Person C
5	1000	Person A	1003	Person D
6	1001	Person B	1004	Person E
7	1001	Person B	1005	Person F
8	1001	Person B	1006	Person G
9	1002	Person C	1007	Person H
10	1002	Person C	1008	Person I
11	1002	Person C	1009	Person J
12	1003	Person D	1010	Person K
13	1003	Person D	1011	Person L
14	1003	Person D	1012	Person M
15	1010	Person K	1013	Person N
16	1010	Person K	1014	Person O
17	1010	Person K	1015	Person P
18	1014	Person O	1016	Person Q
19	1014	Person O	1017	Person R
20	1014	Person O	1018	Person S
21	1014	Person O	1019	Person T
22	1014	Person O	1020	Person U
Source

And sheets as follows:

i.e.:

And the VBA code in a Module of the Workbook, stressing this requires the Microsoft Scripting Runtime as noted:

Option Explicit
' ---------------------------------------------------
' Remember this Module requires Tools>References>
'            Microsoft Scripting Runtime
' to be set in the VBA Window or  it will error with:
' "User Defined Type Not Defined"
' ---------------------------------------------------

Public Sub RunHierarchy()

' ===================================================
' Create the many dictionaries used - note this is
' early binding so heed the warning above regarding
'        *** Microsoft Scripting Runtime ***
' ===================================================
Dim dicSupervisors As Scripting.Dictionary
Set dicSupervisors = New Scripting.Dictionary

Dim dicStaff As Scripting.Dictionary
Set dicStaff = New Scripting.Dictionary

Dim dicStaffReverse As Scripting.Dictionary
Set dicStaffReverse = New Scripting.Dictionary

Dim dicPersonsSupervisor As Scripting.Dictionary
Set dicPersonsSupervisor = New Scripting.Dictionary

Dim dicPersonsChainOfCommand As Scripting.Dictionary
Set dicPersonsChainOfCommand = New Scripting.Dictionary

Dim dicPersonsChainOfCommandSorted As Scripting.Dictionary
Set dicPersonsChainOfCommandSorted = New Scripting.Dictionary

Dim lngLoop As Long, lngLoop2 As Long
Dim rngUsed As Range
Dim strID As String, strName As String, strSuperID As String

' ===================================================
' Fill the dicSupervisors dictionary
' {Key}     {Item}
' 1001      Person B
' ===================================================
' NB: this requires the Supervisors' IDs and Names
' to be in Columns A and B respectively of the Source
' Worksheet
' ===================================================
Set rngUsed = shSource.UsedRange
For lngLoop = 1 To rngUsed.Rows.Count
    strID = rngUsed.Cells(lngLoop, 1).Text
    strName = rngUsed.Cells(lngLoop, 2).Text
    If IsNumeric(strID) And (Not (dicSupervisors.exists(strID))) Then
        dicSupervisors.Add key:=strID, Item:=strName
    End If
Next lngLoop

' ===================================================
' Fill the Staff and StaffReverse dictionaries
' Creates two dictonaries, one (dicStaff) with the structure:
' {Key}     {Item}
' 1001      Person B
'...and the other (dicStaffReverse):
' {Item}    {Key}
' Person B  1001
' ===================================================
' NB: this requires the Staff IDs and Names
' to be in Columns C and D respectively of the Source
' Worksheet
' ===================================================
For lngLoop = 1 To rngUsed.Rows.Count
    strID = rngUsed.Cells(lngLoop, 3).Text
    strName = rngUsed.Cells(lngLoop, 4).Text
    If IsNumeric(strID) And (Not (dicStaff.exists(strID))) Then
        dicStaff.Add key:=strID, Item:=strName
        dicStaffReverse.Add key:=strName, Item:=strID
    End If
Next lngLoop

' ===================================================
' Fill the PersonsSupervisor dictionary
' This will have a structure like:
'       {Key} (Staffer's ID)  {Item} (Manager's ID)
'       1001                  1000
' ===================================================
For lngLoop = 1 To rngUsed.Rows.Count
    strID = rngUsed.Cells(lngLoop, 3).Text
    strSuperID = rngUsed.Cells(lngLoop, 1).Text
    If IsNumeric(strID) And (Not (dicPersonsSupervisor.exists(strID))) Then
        dicPersonsSupervisor.Add key:=strID, Item:=strSuperID
    ElseIf strSuperID = "1000" Then                          ' NB: Hard coded 1000 as the top of the hierarchy
        dicPersonsSupervisor.Add key:=strID, Item:="BOARD"   ' The CEO?! (Doesn't really matter - note used)
    End If
Next lngLoop

' ===================================================
' Build the "Helper" PersonsSupervisors Worksheet.
' This will have a structure like:
'       1000
'       1003    1000
'       1005    1001    1000
' ... which represents the *bottom-up* structure
' with the Staffer reports Manger, reports to Manager,
' to the top of the hierarchy for each Staffer.
' The output to this can be seen
' in the PersonsSupervisors Worksheet (which could
' be hidden if desired, of course)
' ===================================================
Call WritePersonsSupervisors(ThisWorkbook.Worksheets(shPersonsSupervisors.Name), dicPersonsSupervisor)

' ===================================================
' Build the PersonsChainOfCommand dictionary.
' This will have a structure like:
'       {Key}                       {Item} (level)
'       1000.Person A               1
'       1000-1001-1004.Person E     3
'       1000-1001.Person B          2
' ... which represents the *top-down* structure
' with the CEO manages Manger, manages Manager,
' to finally Staffer at the bottom of the top of the
' hierarchy for each Staffer.
' The number at the end (Item) is the level the Staff
' is in the organisation, which is used later when
' "indenting" the output....
' ===================================================
Set rngUsed = shPersonsSupervisors.UsedRange
For lngLoop = 1 To rngUsed.Rows.Count
    strName = rngUsed.Cells(lngLoop, 1).Text & "." & dicStaff(rngUsed.Cells(lngLoop, 1).Text)
    strID = " "
    For lngLoop2 = 2 To rngUsed.Columns.Count
        strID = rngUsed.Cells(lngLoop, lngLoop2).Text & " " & strID & " "
    Next lngLoop2
    strID = Replace(Trim(strID), " ", "-")
    If Len(strID) = 0 Then
        dicPersonsChainOfCommand.Add key:=strName, Item:=CStr(UBound(Split(strID, "-")) + 2)
    Else
        dicPersonsChainOfCommand.Add key:=strID & "-" & strName, Item:=CStr(UBound(Split(strID, "-")) + 2)
    End If
Next lngLoop

' ===================================================
' Sort the PersonsChainOfCommand dictionary
' ===================================================
' This will have a structure like:
'       {Key}                       {Item} (level)
'       1000.Person A               1
'       1000-1001.Person B          2
'       1000-1001-1004.Person E     3
' ===================================================
Set dicPersonsChainOfCommandSorted = SortDictionaryByKey(dicPersonsChainOfCommand, xlAscending)

' ===================================================
' Write the full and selected hierarchies
' ===================================================
Call WriteHierarchy(ThisWorkbook.Worksheets(shFullOrganisationHierarchy.Name), dicPersonsChainOfCommandSorted, dicStaffReverse)
' - Partial (selected) hierarchy
Dim strFromID As String
strFromID = InputBox("Enter a valid staff ID:", "Organisation Hierarchy Bulider")
If dicSupervisors.exists(strFromID) Then
    Call WriteHierarchyFrom(ThisWorkbook.Worksheets(shChosenOrganisationHierarchy.Name), dicPersonsChainOfCommandSorted, dicStaffReverse, strFromID)
Else
    shChosenOrganisationHierarchy.Cells.Clear
    MsgBox ("Sorry, no such manager " & strFromID)
End If
End Sub
' +++ Using dicPersonsSupervisor dictionary
Private Sub WritePersonsSupervisors(shReport As Worksheet, dict As Scripting.Dictionary)
    Dim varKey As Variant
    Dim lngRow As Long, lngColumn As Long, lngRowsN As Long
    shReport.Cells.Clear
    lngRow = 1
    For Each varKey In dict.Keys
        shReport.Cells(lngRow, 1) = varKey
        shReport.Cells(lngRow, 2) = dict(varKey)
        lngRow = lngRow + 1
    Next
    lngRowsN = shReport.UsedRange.Rows.Count
    For lngColumn = 2 To 10
        For lngRow = 1 To lngRowsN
                If shReport.Cells(lngRow, lngColumn).Value = "" Then
                    ' do nothing
                ElseIf shReport.Cells(lngRow, lngColumn) = "1000" Then
                    'do nothing
                Else
                    shReport.Cells(lngRow, lngColumn + 1) = dict(CStr(shReport.Cells(lngRow, lngColumn)))
                End If
            Next lngRow
    Next lngColumn
End Sub
' +++ Using dicPersonsChainOfCommandSorted, dicStaffReverse
Private Sub WriteHierarchy(shReport As Worksheet, dict As Scripting.Dictionary, dict2 As Scripting.Dictionary)
    shReport.Cells.Clear
    Dim varKey As Variant, lngRow As Long
    lngRow = 1
    For Each varKey In dict.Keys
        shReport.Cells(lngRow, CInt(dict(varKey)) + 1) = Split(varKey, ".")(1)
        shReport.Cells(lngRow, CInt(dict(varKey))) = dict2(Split(varKey, ".")(1))
        lngRow = lngRow + 1
    Next
End Sub
' +++ Using 1) dicPersonsChainOfCommandSorted and 2) dicStaffReverse dictionaries
Private Sub WriteHierarchyFrom(shReport As Worksheet, dict As Scripting.Dictionary, dict2 As Scripting.Dictionary, strID As String)
    shReport.Cells.Clear
    Dim varKey As Variant, lngRow As Long
    lngRow = 1
    For Each varKey In dict.Keys
        If UBound(Split(varKey, strID)) > 0 Then
            shReport.Cells(lngRow, CInt(dict(varKey)) + 1) = Split(varKey, ".")(1)
            shReport.Cells(lngRow, CInt(dict(varKey))) = dict2(Split(varKey, ".")(1))
        End If
        lngRow = lngRow + 1
    Next
    shReport.UsedRange.Cut Destination:=shReport.Range("A1")
End Sub
' Source: From https://excelmacromastery.com/
Public Function SortDictionaryByKey(dict As Object _
                  , Optional sortorder As XlSortOrder = xlAscending) As Object
    Dim arrList As Object
    Set arrList = CreateObject("System.Collections.ArrayList")
    ' Put keys in an ArrayList
    Dim key As Variant, coll As New Collection
    For Each key In dict
        arrList.Add key
    Next key
    ' Sort the keys
    arrList.Sort
    ' For descending order, reverse
    If sortorder = xlDescending Then
        arrList.Reverse
    End If
    ' Create new dictionary
    Dim dictNew As Object
    Set dictNew = CreateObject("Scripting.Dictionary")
    ' Read through the sorted keys and add to new dictionary
    For Each key In arrList
        dictNew.Add key, dict(key)
    Next key
    ' Clean up
    Set arrList = Nothing
    Set dict = Nothing
    ' Return the new dictionary
    Set SortDictionaryByKey = dictNew
End Function

Outputs:

and, say 1010 is entered into the Input Box:

 

[DanteAmor]

Here another macro for you to consider.

Type the supervisor ID in cell E1.
The result will be shown from column F onwards.

varios 14feb2020.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Supervisor ID	Supervisor Name	Person ID	Person Name	1003
2			1000	Person A		1003	Person D
3	1000	Person A	1001	Person B			1010	Person K
4	1000	Person A	1002	Person C				1013	Person N
5	1000	Person A	1003	Person D				1014	Person O
6	1001	Person B	1004	Person E					1016	Person Q
7	1001	Person B	1005	Person F					1017	Person R
8	1001	Person B	1006	Person G					1018	Person S
9	1002	Person C	1007	Person H					1019	Person T
10	1002	Person C	1008	Person I					1020	Person U
11	1002	Person C	1009	Person J				1015	Person P
12	1003	Person D	1010	Person K			1011	Person L
13	1003	Person D	1011	Person L			1012	Person M
14	1003	Person D	1012	Person M
15	1010	Person K	1013	Person N
16	1010	Person K	1014	Person O
17	1010	Person K	1015	Person P
18	1014	Person O	1016	Person Q
19	1014	Person O	1017	Person R
20	1014	Person O	1018	Person S
21	1014	Person O	1019	Person T
22	1014	Person O	1020	Person U
employees

Option Explicit
Dim a As Variant, b As Variant, j As Long, k As Long
Dim dic As Object

Sub HierarchySupervisor()
  Dim i As Long, sId As Variant, dic1 As Object, col As Variant
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set dic1 = CreateObject("Scripting.Dictionary")
  Range("F2", Cells(Rows.Count, Columns.Count)).ClearContents
  
  a = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To 1)
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 1))
  For i = 1 To UBound(a, 1)
    dic1(a(i, 3)) = a(i, 4)
  Next
  
  j = 1
  k = 1
  sId = Range("E1")
  b(j, k) = sId
  dic(sId) = k
  k = 2
  Call recur(sId)
  
  For i = 1 To j
    col = dic(b(i, 1))
    c(i, col) = b(i, 1)
    c(i, col + 1) = dic1(b(i, 1))
  Next
  Range("F2").Resize(dic.Count, UBound(c, 2)).Value = c
End Sub

Sub recur(n)
  Dim i As Long, personID As New Collection, num As Variant
  For i = 1 To UBound(a, 1)
    If a(i, 1) = n Then
      dic(a(i, 3)) = k
      personID.Add a(i, 3)
    End If
  Next
  For Each num In personID
    j = j + 1
    b(j, 1) = num
    k = k + 1
    Call recur(num)
    k = k - 1
  Next
End Sub

 

[kennypete]

Nice @DanteAmor - that’s a succinct answer to the use case. I guess it depends how extensible @PJVV77 wants this to be and/or whether the nested recursion is too much to fathom. I’ve other uses for the PersonsChainOfCommand dictionary, which I think is easy to visualise. For a in-1-sheet solution though, yours is right on.

 

[DanteAmor]

Thanks Kenny I appreciate your kind comments.

It would be necessary to perform several tests and with more data to determine if it performs all the nests. ?

 

[Harry2020]

Good morning all,

Didn't want to start a new thread as this seems relevant (apologies for piggybacking onto it if it's bad etiquette).

I have a similar need but the output needs to be different.

I run staff reports and on many occasions, management do not want to see it by department but by head of/director.

So to cut a long story short; an example of my data might look like:

Employee ID - Employee Name - Supervisor ID - Supervisor Name

Is it at all possible to pop in a managers name into a box/cell and for it to return everyone under their supervisor hierarchy (so all staff including other supervisors under their leadership).

Apologies if I'm not making that clear but thank you for any assistance.

 

[DanteAmor]

I also take the opportunity to put the link to another similar situation of recursion:

Speed up parent child hierarchy macro

i have macro for parent child hierarchy macro but i want to run the same for more than 20000 rows can it be speed up Option Explicit Const SourceDivCol = 1 Const SourcePosCol = 2 Const SourceRepCol = 3 Const SourceLevCol = 4 Const SourceEmpCol = 5 Const SourceCodCol = 6 Const TargetDivCol =...

www.mrexcel.com

I hope it helps you.
With affection Dante Amor.

 

[Luffy323]

Here another macro for you to consider.

Type the supervisor ID in cell E1.
The result will be shown from column F onwards.

varios 14feb2020.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Supervisor ID	Supervisor Name	Person ID	Person Name	1003
2			1000	Person A		1003	Person D
3	1000	Person A	1001	Person B			1010	Person K
4	1000	Person A	1002	Person C				1013	Person N
5	1000	Person A	1003	Person D				1014	Person O
6	1001	Person B	1004	Person E					1016	Person Q
7	1001	Person B	1005	Person F					1017	Person R
8	1001	Person B	1006	Person G					1018	Person S
9	1002	Person C	1007	Person H					1019	Person T
10	1002	Person C	1008	Person I					1020	Person U
11	1002	Person C	1009	Person J				1015	Person P
12	1003	Person D	1010	Person K			1011	Person L
13	1003	Person D	1011	Person L			1012	Person M
14	1003	Person D	1012	Person M
15	1010	Person K	1013	Person N
16	1010	Person K	1014	Person O
17	1010	Person K	1015	Person P
18	1014	Person O	1016	Person Q
19	1014	Person O	1017	Person R
20	1014	Person O	1018	Person S
21	1014	Person O	1019	Person T
22	1014	Person O	1020	Person U
employees

Option Explicit
Dim a As Variant, b As Variant, j As Long, k As Long
Dim dic As Object

Sub HierarchySupervisor()
  Dim i As Long, sId As Variant, dic1 As Object, col As Variant
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set dic1 = CreateObject("Scripting.Dictionary")
  Range("F2", Cells(Rows.Count, Columns.Count)).ClearContents
 
  a = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To 1)
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 1))
  For i = 1 To UBound(a, 1)
    dic1(a(i, 3)) = a(i, 4)
  Next
 
  j = 1
  k = 1
  sId = Range("E1")
  b(j, k) = sId
  dic(sId) = k
  k = 2
  Call recur(sId)
 
  For i = 1 To j
    col = dic(b(i, 1))
    c(i, col) = b(i, 1)
    c(i, col + 1) = dic1(b(i, 1))
  Next
  Range("F2").Resize(dic.Count, UBound(c, 2)).Value = c
End Sub

Sub recur(n)
  Dim i As Long, personID As New Collection, num As Variant
  For i = 1 To UBound(a, 1)
    If a(i, 1) = n Then
      dic(a(i, 3)) = k
      personID.Add a(i, 3)
    End If
  Next
  For Each num In personID
    j = j + 1
    b(j, 1) = num
    k = k + 1
    Call recur(num)
    k = k - 1
  Next
End Sub

Hi Dante, your code is incredible. May I know, how to modify the code to fit with my work? I need to add one more column beside supervisor name and person name.

 

[Schristy]

Hi Dante, your code is incredible. May I know, how to modify the code to fit with my work? I need to add one more column beside supervisor name and person name.

Hi This is also an incredible one. However if i run it multiple times on diffferent ID's it give an runtime error, out of memory. I have tried resetting the variables and ranges here. but no luck

any help pls ?

 

[DanteAmor]

Hi @Schristy , welcome to MrExcel board.

I did tests with 1,300 people and 15 levels and I have no problems.
With how many people are you doing your tests and how many levels of hierarchy do you have?

I added a couple of lines to the macro to clear the variables, maybe that will help.

Option Explicit

Dim a As Variant, b As Variant, j As Long, k As Long
Dim dic As Object

Sub HierarchySupervisor()
  Dim i As Long, sId As Variant, dic1 As Object, col As Variant
  Application.ScreenUpdating = False
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set dic1 = CreateObject("Scripting.Dictionary")
  Range("F2", Cells(Rows.Count, Columns.Count)).ClearContents
  
  a = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To 1)
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 1))
  For i = 1 To UBound(a, 1)
    dic1(a(i, 3)) = a(i, 4)
  Next
  
  j = 1
  k = 1
  sId = Range("E1")
  b(j, k) = sId
  dic(sId) = k
  k = 2
  Call recur(sId)
  
  For i = 1 To j
    col = dic(b(i, 1))
    c(i, col) = b(i, 1)
    c(i, col + 1) = dic1(b(i, 1))
  Next
  Range("F2").Resize(dic.Count, UBound(c, 2)).Value = c
  Application.ScreenUpdating = True
  
  Erase a, b, c
  Set dic = Nothing
End Sub

Sub recur(n)
  Dim i As Long, personID As New Collection, num As Variant
  For i = 1 To UBound(a, 1)
    If a(i, 1) = n Then
      dic(a(i, 3)) = k
      personID.Add a(i, 3)
    End If
  Next
  For Each num In personID
    j = j + 1
    b(j, 1) = num
    k = k + 1
    Call recur(num)
    k = k - 1
  Next
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​