Code Optimization with dictionnary?

[jbesclapez]

Hello,

I have some data in column A an B being Child and Parent relationship.
I made this code to order :

Sub SortHierarchy()
  Tabl2 = Range("A2:B" & [A65000].End(xlUp).row).Value
  Set debOrg2 = [G1]
  debOrg2.Offset(1).Resize(25, 2).ClearContents
  m = UBound(Tabl2)
  row2 = 0
  For l = 1 To m
     If Tabl2(l, 2) = "" Then DesignMe2 Tabl2(l, 1), 1, Tabl2(l, 2)
  Next l
  Columns("J:L").EntireColumn.AutoFit
  'Call CheckHierarchy
End Sub

Sub DesignMe2(parent2, level, comp)
  row2 = row2 + 1
  debOrg2.Offset(row2) = parent2: debOrg2.Offset(row2, 1) = comp
  For j = 1 To m
     If Tabl2(j, 2) = parent2 Then DesignMe2 Tabl2(j, 1), level + 1, Tabl2(j, 2)
  Next j
End Sub

The code is giving the result expect. BUT... (there is always a but, right?)... when I have a big amount of data, it runs to slowly.
I asked OpenAI to optimize the code and it comes with that result which is NOT working.
The error is on line "If parent2(2) = "" Then"

Sub SortHierarchy()
Dim Tabl2() As Variant
Dim debOrg2 As Range
Dim nodes As Object
Dim parent2 As Variant
Dim level As Long
Dim comp As Variant
Dim row2 As Long
Dim j As Long

' Load data from worksheet into array
Tabl2 = Range("A2:B" & [A65000].End(xlUp).row).Value

' Set up output range
Set debOrg2 = [G1]
debOrg2.Offset(1).Resize(25, 2).ClearContents

' Set up dictionary to keep track of nodes
Set nodes = CreateObject("Scripting.Dictionary")

' Process nodes
For Each parent2 In Tabl2
If parent2(2) = "" Then DesignMe2 parent2(1), 1, parent2(2), nodes, Tabl2
Next parent2

Columns("J:L").EntireColumn.AutoFit
End Sub

Sub DesignMe2(parent2, level, comp, nodes As Object, Tabl2() As Variant)
Dim row2 As Long
Dim child As Variant

' Check if node has already been processed
If nodes.exists(parent2) Then Exit Sub

' Add node to output range
row2 = debOrg2.Cells(debOrg2.Rows.Count, 1).End(xlUp).row + 1
debOrg2.Offset(row2 - 1) = parent2
debOrg2.Offset(row2 - 1, 1) = comp

' Add node to dictionary
nodes.Add parent2, True

' Process children
For Each child In Tabl2
If child(2) = parent2 Then DesignMe2 child(1), level + 1, child(2), nodes, Tabl2
Next child
End Sub

I undertand the use of dictionnary, but I am not familiar with it.
Could someone help optimizing the code but that it works.

Thanks

 

[sleek12]

The error you're seeing on the line "If parent2(2) = "" Then" is because you're trying to access the second element of the parent2 array, which doesn't exist in this case. This is because the loop variable parent2 is a single element of the Tabl2 array, which is a 2-dimensional array with columns A and B.
To fix this error, you should use parent2(1) to access the first element of the parent2 array, which corresponds to the child value in column A.
Here's the optimized code:

Sub SortHierarchy()
    Dim Tabl2() As Variant
    Dim debOrg2 As Range
    Dim nodes As Object
    Dim parent2 As Variant
    Dim level As Long
    Dim comp As Variant
    Dim row2 As Long
    Dim j As Long

    ' Load data from worksheet into array
    Tabl2 = Range("A2:B" & [A65000].End(xlUp).Row).Value

    ' Set up output range
    Set debOrg2 = [G1]
    debOrg2.Offset(1).Resize(25, 2).ClearContents

    ' Set up dictionary to keep track of nodes
    Set nodes = CreateObject("Scripting.Dictionary")

    ' Process nodes
    For Each parent2 In Tabl2
        If parent2(2) = "" Then DesignMe2 parent2(1), 1, parent2(2), nodes, Tabl2, debOrg2
    Next parent2

    Columns("J:L").EntireColumn.AutoFit
End Sub

Sub DesignMe2(parent2, level, comp, nodes As Object, Tabl2() As Variant, debOrg2 As Range)
    Dim row2 As Long
    Dim child As Variant

    ' Check if node has already been processed
    If nodes.exists(parent2) Then Exit Sub

    ' Add node to output range
    row2 = debOrg2.Cells(debOrg2.Rows.Count, 1).End(xlUp).row + 1
    debOrg2.Offset(row2 - 1) = parent2
    debOrg2.Offset(row2 - 1, 1) = comp

    ' Add node to dictionary
    nodes.Add parent2, True

    ' Process children
    For Each child In Tabl2
        If child(2) = parent2 Then DesignMe2 child(1), level + 1, child(2), nodes, Tabl2, debOrg2
    Next child
End Sub

 

[jbesclapez]

The error you're seeing on the line "If parent2(2) = "" Then" is because you're trying to access the second element of the parent2 array, which doesn't exist in this case. This is because the loop variable parent2 is a single element of the Tabl2 array, which is a 2-dimensional array with columns A and B.
To fix this error, you should use parent2(1) to access the first element of the parent2 array, which corresponds to the child value in column A.
Here's the optimized code:

Sub SortHierarchy()
    Dim Tabl2() As Variant
    Dim debOrg2 As Range
    Dim nodes As Object
    Dim parent2 As Variant
    Dim level As Long
    Dim comp As Variant
    Dim row2 As Long
    Dim j As Long

    ' Load data from worksheet into array
    Tabl2 = Range("A2:B" & [A65000].End(xlUp).Row).Value

    ' Set up output range
    Set debOrg2 = [G1]
    debOrg2.Offset(1).Resize(25, 2).ClearContents

    ' Set up dictionary to keep track of nodes
    Set nodes = CreateObject("Scripting.Dictionary")

    ' Process nodes
    For Each parent2 In Tabl2
    [COLOR=rgb(251, 160, 38)] [/COLOR][COLOR=rgb(184, 49, 47)][B][I]   If parent2(2) = "" Then[/I][/B][/COLOR] DesignMe2 parent2(1), 1, parent2(2), nodes, Tabl2, debOrg2
    Next parent2

    Columns("J:L").EntireColumn.AutoFit
End Sub

Sub DesignMe2(parent2, level, comp, nodes As Object, Tabl2() As Variant, debOrg2 As Range)
    Dim row2 As Long
    Dim child As Variant

    ' Check if node has already been processed
    If nodes.exists(parent2) Then Exit Sub

    ' Add node to output range
    row2 = debOrg2.Cells(debOrg2.Rows.Count, 1).End(xlUp).row + 1
    debOrg2.Offset(row2 - 1) = parent2
    debOrg2.Offset(row2 - 1, 1) = comp

    ' Add node to dictionary
    nodes.Add parent2, True

    ' Process children
    For Each child In Tabl2
        If child(2) = parent2 Then DesignMe2 child(1), level + 1, child(2), nodes, Tabl2, debOrg2
    Next child
End Sub

Hi @sleek12,
I just had some time to test your changes.
Unfortunately, i get an error again Type Mistmach in the function SortHIerarchy where the "If parent2()" (see above).
Thanks for your help!