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

 

[Schristy]

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

 

[DanteAmor]

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:

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
--------------​

 

[Schristy]

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