VBA Code to run hierarchy

PJVV77

New Member
Joined
Aug 2, 2019
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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
 
Hi @DanteAmor thanks for getting back so quickly.

I have about 10700 rows of data to be processed with 12 different supervisors. I had also applied the clear variables, but no luck.

The error occurs at this line - ReDim c(1 To UBound(a, 1), 1 To UBound(a, 1)), sometimes during the 2nd run / 3rd run.

What I have also done is automatically pick the supervisors ID from a different sheet, which is expected to run 12 times, after moving each run data to a new sheet before processing the next one.

Can the data also be aligned in 1 single column ? (Currently i have coded this as a different function)

Thanks and really appreciate your help, awaiting your response.

regards
Schristy
 
Upvote 0

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Can the data also be aligned in 1 single column ?
That solves everything, the output will only be 2 columns: ID and Person name.


Try this:
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
  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 2)    'For a 2 column output.
  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))
    col = 1                             'Align to a single column
    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


--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
Hi @DanteAmor it worked like a charm. Did not throw runtime error. All aligned in 2 columns . did what i exactly needed. Will have a look at the changes tomorrow. :)

thanks so much for your help.

regards
Schristy
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,847
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top