Speed up parent child hierarchy macro

[sachin483]

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 = 15
Const TargetLevCol = 16
Const TargetPosCol = 17
Const TargetEmpCol = 18
Const TargetCodCol = 19
Dim SourceRow As Long
Dim TargetRow As Long

Sub CreateReport()
    Dim Boss As Range
    Dim Adr As String
    Dim Pos As String
    Application.ScreenUpdating = False
    TargetRow = 2
    Set Boss = Columns(SourceLevCol).Find(What:=1, LookAt:=xlWhole)
    Adr = Boss.Address
    Do
        SourceRow = Boss.Row
        TargetRow = TargetRow + 1
        Cells(TargetRow, TargetDivCol).Value = Cells(SourceRow, SourceDivCol).Value
        Cells(TargetRow, TargetLevCol).Value = Cells(SourceRow, SourceLevCol).Value
        Cells(TargetRow, TargetPosCol).Value = Cells(SourceRow, SourcePosCol).Value
        Cells(TargetRow, TargetEmpCol).Value = Cells(SourceRow, SourceEmpCol).Value
        Cells(TargetRow, TargetCodCol).Value = Cells(SourceRow, SourceCodCol).Value
        Pos = Cells(SourceRow, SourcePosCol).Value
        Call AddChildren(Pos)
        Set Boss = Columns(SourceLevCol).Find(What:=1, After:=Boss, LookAt:=xlWhole)
        If Boss Is Nothing Then Exit Do
    Loop Until Boss.Address = Adr
    Application.ScreenUpdating = True
End Sub

Sub AddChildren(BossPos As String)
    Dim Child As Range
    Dim Adr As String
    Dim Pos As String
    Set Child = Columns(SourceRepCol).Find(What:=BossPos, LookAt:=xlWhole)
    If Child Is Nothing Then Exit Sub
    Adr = Child.Address
    Do
        SourceRow = Child.Row
        TargetRow = TargetRow + 1
        Cells(TargetRow, TargetDivCol).Value = Cells(SourceRow, SourceDivCol).Value
        Cells(TargetRow, TargetLevCol).Value = Cells(SourceRow, SourceLevCol).Value
        Cells(TargetRow, TargetPosCol).Value = Cells(SourceRow, SourcePosCol).Value
        Cells(TargetRow, TargetEmpCol).Value = Cells(SourceRow, SourceEmpCol).Value
        Cells(TargetRow, TargetCodCol).Value = Cells(SourceRow, SourceCodCol).Value
        Pos = Cells(SourceRow, SourcePosCol).Value
        Call AddChildren(Pos)
        Set Child = Columns(SourceRepCol).Find(What:=BossPos, After:=Child, LookAt:=xlWhole)
        If Child Is Nothing Then Exit Do
    Loop Until Child.Address = Adr
End Sub

 

[DanteAmor]

Hi @sachin483.

The process is slow because you are using methods like FIND that search the sheet directly, and also because you are updating directly on the sheet:

Sub CreateReport()
...
    TargetRow = 2
    Set Boss = Columns(SourceLevCol).Find(What:=1, LookAt:=xlWhole)
    Do
        Cells(TargetRow, TargetDivCol).Value = Cells(SourceRow, SourceDivCol).Value
...
        Pos = Cells(SourceRow, SourcePosCol).Value
        Call AddChildren(Pos)
        Set Boss = Columns(SourceLevCol).Find(What:=1, After:=Boss, LookAt:=xlWhole)
...
End Sub

Sub AddChildren(BossPos As String)
...
    Set Child = Columns(SourceRepCol).Find(What:=BossPos, LookAt:=xlWhole)
...
        Cells(TargetRow, TargetDivCol).Value = Cells(SourceRow, SourceDivCol).Value
...
        Set Child = Columns(SourceRepCol).Find(What:=BossPos, After:=Child, LookAt:=xlWhole)
...
End Sub

To improve the process you should use other tools like dictionaries and arrays, which perform all operations in memory, the design should read only once from the sheet and write only once to the sheet. Let me explain, while your process performs many reads of the sheet and many writes to the sheet, with this type of technique you will only perform 1 read and 1 write.

But to help you and understand how your macro works, it is necessary that you provide us with a sample of your data and the result you want.
It would be great if you could share a workbook with the following: on sheet1 the original data and on sheet2 the result you want.

You could upload a copy of your file to a free site such www.dropbox.com or google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.​

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

 

[sachin483]

Thanks for explaining @DanteAmor

drop box link share with file

dropbox

 

[DanteAmor]

Try the following code.
In the sample file and some other tests I ran it works fine.
But you must try with the 20000 rows. You tell me how the test worked.
How long did your macro take and how long did my macro take.

Oh, and a little detail, according to your example, the starting position is in cell C2.

Option Explicit

Dim j As Long
Dim dic1 As Object, dic2 As Object
Dim a As Variant, b As Variant, dta As Variant

Sub Level_Position_Module4()
  Dim i As Long, y As Long, fil As Long, col As Long
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
    
  a = Range("A2:F" & Range("C" & Rows.Count).End(xlUp).Row).Value2
  ReDim b(1 To UBound(a, 1) + 2, 1 To 5)              'output array
  ReDim dta(1 To UBound(a, 1), 1 To UBound(a, 1))     'array with rows and columns from array 'a'
  
  For i = 1 To UBound(a, 1)
    dic1(a(i, 2)) = a(i, 1) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
    If Not dic2.exists(a(i, 3)) Then
      y = y + 1
      dta(y, 1) = i
      dic2(a(i, 3)) = y & "|" & 1
    Else
      fil = Split(dic2(a(i, 3)), "|")(0)
      col = Split(dic2(a(i, 3)), "|")(1)
      col = col + 1
      dta(fil, col) = i
      dic2(a(i, 3)) = fil & "|" & col
    End If
  Next
  
  Call recur(Range("C2").Value)                               'initial position
  Range("Q2").Resize(UBound(b, 1), UBound(b, 2)).Value = b    'Output
  j = 0
End Sub

Sub recur(pos)
  Dim num As Variant, i&, fil&, col&, nrow&
  
  If dic2.exists(pos) Then
    fil = Split(dic2(pos), "|")(0)
    col = Split(dic2(pos), "|")(1)
    For i = 1 To col
      nrow = dta(fil, i)
      num = a(nrow, 2)
      j = j + 1
      b(j, 1) = Split(dic1(num), "|")(0)
      b(j, 2) = Split(dic1(num), "|")(1)
      b(j, 3) = num
      b(j, 4) = Split(dic1(num), "|")(2)
      b(j, 5) = Split(dic1(num), "|")(3)
      Call recur(num)                     'recursion
    Next
  End If
End Sub

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

 

[sachin483]

@DanteAmor tried on sample date the result is showing blank with only heading

 

[DanteAmor]

Tty your example from post #3.
The examples you test should have the same structure as your example.

If it has the same structure and it doesn't work then share your file for me to review.

 

[sachin483]

@DanteAmor file copied with macro

Dropbox

 

[DanteAmor]

Sorry, it's my mistake, I assumed the first row in your original file shouldn't be there.
So your data starts at row 3 and the result too:

The change is minimal in the macro, I only changed the "2" to a "3".

I'll give you the modified code, try it and tell me.

Dim j As Long
Dim dic1 As Object, dic2 As Object
Dim a As Variant, b As Variant, dta As Variant

Sub Level_Position_Module4()
  Dim i As Long, y As Long, fil As Long, col As Long
 
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
      'initial data start in row 3
  a = Range("A3:F" & Range("C" & Rows.Count).End(xlUp).Row).Value2
  ReDim b(1 To UBound(a, 1) + 2, 1 To 5)              'output array
  ReDim dta(1 To UBound(a, 1), 1 To UBound(a, 1))     'array with rows and columns from array 'a'
 
  For i = 1 To UBound(a, 1)
    dic1(a(i, 2)) = a(i, 1) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
    If Not dic2.exists(a(i, 3)) Then
      y = y + 1
      dta(y, 1) = i
      dic2(a(i, 3)) = y & "|" & 1
    Else
      fil = Split(dic2(a(i, 3)), "|")(0)
      col = Split(dic2(a(i, 3)), "|")(1)
      col = col + 1
      dta(fil, col) = i
      dic2(a(i, 3)) = fil & "|" & col
    End If
  Next
 
  Call recur(a(1, 3))                                         'initial position
  Range("Q3").Resize(UBound(b, 1), UBound(b, 2)).Value = b    'Output
  j = 0
End Sub

Sub recur(pos)
  Dim num As Variant, i&, fil&, col&, nrow&
 
  If dic2.exists(pos) Then
    fil = Split(dic2(pos), "|")(0)
    col = Split(dic2(pos), "|")(1)
    For i = 1 To col
      nrow = dta(fil, i)
      num = a(nrow, 2)
      j = j + 1
      b(j, 1) = Split(dic1(num), "|")(0)
      b(j, 2) = Split(dic1(num), "|")(1)
      b(j, 3) = num
      b(j, 4) = Split(dic1(num), "|")(2)
      b(j, 5) = Split(dic1(num), "|")(3)
      Call recur(num)                     'recursion
    Next
  End If
End Sub

I also share the same file with the code and the result.

report hierarchy.xlsm

drive.google.com

.

 

[DanteAmor]

I would like to add the example of this hierarchy made with recursion, since it is an important topic but very few solutions:

Input data:

Dante Amor
	A	B	C	D	E	F
1	DATA
2	DIVISION	POSITION	POSITION REPORTING	LEVEL_NO	empno	code
3	XX	OZ00301	INDOL	1	E1	LL81
4	XX	LR0201	OZ00301	2	E2	LL82
5	XX	LA0101	LR0201	3	E3	LL83
6	XX	LA0201	LR0201	3	E4	LL84
7	XX	LA0701	LR0201	3	E5	LL85
8	XX	XX0502	LA0201	4	E6	LL86
9	XX	XX0601	LA0201	4	E7	LL87
10	XX	XX1901	LA0201	4	E8	LL88
11	XX	XX2101	LA0201	4	E9	LL89
12	XX	XX2201	LA0701	4	E10	LL90
13	XX	XX0101	LA0101	4	E11	LL91
14	XX	XX0102	LA0101	4	E12	LL92
15	XX	XX0103	LA0101	4	E13	LL93
16	XX	XX0104	LA0101	4	E14	LL94
17	XX	XX0201	LA0701	4	E15	LL95
18	XX	XX0301	LA0701	4	E16	LL96
19	XX	XX0501	LA0201	4	E17	LL97
Sheet1

Results:

Dante Amor
	O	P	Q	R	S	T	U
1	Result of Macro
2	DIVISION	LEVEL_NO	DIVISION	LEVEL_NO	POSITION	empno	code
3	XX	1	XX	1	OZ00301	E1	LL81
4	XX	2	XX	2	LR0201	E2	LL82
5	XX	3	XX	3	LA0101	E3	LL83
6	XX	4	XX	4	XX0101	E11	LL91
7	XX	4	XX	4	XX0102	E12	LL92
8	XX	4	XX	4	XX0103	E13	LL93
9	XX	4	XX	4	XX0104	E14	LL94
10	XX	3	XX	3	LA0201	E4	LL84
11	XX	4	XX	4	XX0502	E6	LL86
12	XX	4	XX	4	XX0601	E7	LL87
13	XX	4	XX	4	XX1901	E8	LL88
14	XX	4	XX	4	XX2101	E9	LL89
15	XX	4	XX	4	XX0501	E17	LL97
16	XX	3	XX	3	LA0701	E5	LL85
17	XX	4	XX	4	XX2201	E10	LL90
18	XX	4	XX	4	XX0201	E15	LL95
19	XX	4	XX	4	XX0301	E16	LL96
Sheet1

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

VBA Code to run hierarchy

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

www.mrexcel.com

I hope it helps you.
With affection Dante Amor.

 

[sachin483]

@DanteAmor

If the level no is sorted then only its work ie:- level 1 should be on top , if level no. is sorted from largest to small then it doesn't work