VBA Code to run hierarchy

PJVV77

New Member
Joined
Aug 2, 2019
Messages
6
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 IDSupervisor NamePerson IDPerson 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

Board Regular
Joined
Apr 19, 2008
Messages
117
Office Version
365, 2019
Platform
Windows
Here is one solution to this. Conveniently, I needed something similar myself...serendipity!

Using your data, in a Worksheet shSource named Source:
Book1
ABCD
1Supervisor IDSupervisor NamePerson IDPerson Name
21000Person A
31000Person A1001Person B
41000Person A1002Person C
51000Person A1003Person D
61001Person B1004Person E
71001Person B1005Person F
81001Person B1006Person G
91002Person C1007Person H
101002Person C1008Person I
111002Person C1009Person J
121003Person D1010Person K
131003Person D1011Person L
141003Person D1012Person M
151010Person K1013Person N
161010Person K1014Person O
171010Person K1015Person P
181014Person O1016Person Q
191014Person O1017Person R
201014Person O1018Person S
211014Person O1019Person T
221014Person O1020Person U
Source


And sheets as follows:
1581743164406.png

i.e.:
1581743183902.png


And the VBA code in a Module of the Workbook, stressing this requires the Microsoft Scripting Runtime as noted:
VBA Code:
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:
1581743332450.png


1581743354064.png


and, say 1010 is entered into the Input Box:
1581743399774.png
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
9,707
Office Version
2007
Platform
Windows
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
ABCDEFGHIJ
1Supervisor IDSupervisor NamePerson IDPerson Name1003
21000Person A1003Person D
31000Person A1001Person B1010Person K
41000Person A1002Person C1013Person N
51000Person A1003Person D1014Person O
61001Person B1004Person E1016Person Q
71001Person B1005Person F1017Person R
81001Person B1006Person G1018Person S
91002Person C1007Person H1019Person T
101002Person C1008Person I1020Person U
111002Person C1009Person J1015Person P
121003Person D1010Person K1011Person L
131003Person D1011Person L1012Person M
141003Person D1012Person M
151010Person K1013Person N
161010Person K1014Person O
171010Person K1015Person P
181014Person O1016Person Q
191014Person O1017Person R
201014Person O1018Person S
211014Person O1019Person T
221014Person O1020Person U
employees



VBA Code:
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

Board Regular
Joined
Apr 19, 2008
Messages
117
Office Version
365, 2019
Platform
Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
9,707
Office Version
2007
Platform
Windows
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. 🍻
 

Forum statistics

Threads
1,085,788
Messages
5,385,895
Members
401,975
Latest member
OnPoint

Some videos you may like

This Week's Hot Topics

Top