Adjustment to Parent Child VBA Script

Carl_H

New Member
Joined
Sep 16, 2014
Messages
18
First of all I apologize for adding Urgent* to the title but need to solve this ASAP.

I have a script that are looping through a generation format and change it to parent child structure.

The script loops through column 1,3,5,7 and creates a Parent and Child column in a new sheet.

What I would like to add is to add a 3rd column in my output sheet with "Child Description". Information should be taken from column 2,4,6,8.

I don't think it should be that much work to add but my VBA skills are terrible :(
VBA Code:
Sub Gen_to_ParentChild()
Dim Dic As Object, n As Long
Dim k As Variant, Ac As Long
Dim p As Variant, c As Long
Dim Ray As Variant, col As Variant

Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
Ray = Range("A1").CurrentRegion
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 2)
c = 1
col = Array(1, 3, 5, 7) ' Place columns you want to loop through here. Like:- Array(1,3,5,7,9,11 etc)
For Ac = 0 To UBound(col) - 1
For n = 2 To UBound(Ray, 1)
If Not Dic.Exists(Ray(n, col(Ac))) Then
Set Dic(Ray(n, col(Ac))) = CreateObject("Scripting.Dictionary")
End If

If Not Dic(Ray(n, col(Ac))).Exists(Ray(n, col(Ac + 1))) Then
Dic(Ray(n, col(Ac))).Add (Ray(n, col(Ac + 1))), ""
End If
Next n

nray(1, 1) = "Parent": nray(1, 2) = "Child"
For Each k In Dic.Keys
If c = 1 Then
c = c + 1
nray(c, 1) = k
End If
For Each p In Dic(k)
c = c + 1
nray(c, 1) = k
nray(c, 2) = p
Next p
Next k
Dic.RemoveAll
Next Ac
With Sheets("Sheet2").Range("a1").Resize(c, 2)
.Value = nray
.Columns.AutoFit
.Borders.Weight = 2
.HorizontalAlignment = xlCenter
End With
End Sub
 
Last edited by a moderator:

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

mart37

Well-known Member
Joined
Aug 4, 2017
Messages
1,090
Office Version
  1. 2016
Platform
  1. Windows
Rich (BB code):
Sub Gen_to_ParentChild()
Dim Dic As Object, n As Long
Dim k As Variant, Ac As Long
Dim p As Variant, c As Long
Dim Ray As Variant, col As Variant

Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
Ray = Range("A1").CurrentRegion
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 3)
c = 1
col = Array(1, 3, 5, 7) ' Place columns you want to loop through here. Like:- Array(1,3,5,7,9,11 etc)
For Ac = 0 To UBound(col) - 1
    For n = 2 To UBound(Ray, 1)
        If Not Dic.Exists(Ray(n, col(Ac))) Then
            Set Dic(Ray(n, col(Ac))) = CreateObject("Scripting.Dictionary")
        End If
       
        If Not Dic(Ray(n, col(Ac))).Exists(Ray(n, col(Ac + 1))) Then
            Dic(Ray(n, col(Ac))).Add (Ray(n, col(Ac + 1))), Ray(n, col(Ac) + 1) & " - " & Ray(n, col(Ac + 1) + 1)
        End If
    Next n
   
    nray(1, 1) = "Parent": nray(1, 2) = "Child": nray(1, 3) = "Child Desc."
    For Each k In Dic.Keys
        If c = 1 Then
            c = c + 1
            nray(c, 1) = k
        End If
        For Each p In Dic(k)
            c = c + 1
            nray(c, 1) = k
            nray(c, 2) = p
            nray(c, 3) = Dic(k)(p)
        Next p
    Next k
    Dic.RemoveAll
Next Ac
With Sheets("sheet2").Range("a1").Resize(c, 3)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
    .HorizontalAlignment = xlCenter
End With
End Sub
 

Carl_H

New Member
Joined
Sep 16, 2014
Messages
18
Rich (BB code):
Sub Gen_to_ParentChild()
Dim Dic As Object, n As Long
Dim k As Variant, Ac As Long
Dim p As Variant, c As Long
Dim Ray As Variant, col As Variant

Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
Ray = Range("A1").CurrentRegion
ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 3)
c = 1
col = Array(1, 3, 5, 7) ' Place columns you want to loop through here. Like:- Array(1,3,5,7,9,11 etc)
For Ac = 0 To UBound(col) - 1
    For n = 2 To UBound(Ray, 1)
        If Not Dic.Exists(Ray(n, col(Ac))) Then
            Set Dic(Ray(n, col(Ac))) = CreateObject("Scripting.Dictionary")
        End If
      
        If Not Dic(Ray(n, col(Ac))).Exists(Ray(n, col(Ac + 1))) Then
            Dic(Ray(n, col(Ac))).Add (Ray(n, col(Ac + 1))), Ray(n, col(Ac) + 1) & " - " & Ray(n, col(Ac + 1) + 1)
        End If
    Next n
  
    nray(1, 1) = "Parent": nray(1, 2) = "Child": nray(1, 3) = "Child Desc."
    For Each k In Dic.Keys
        If c = 1 Then
            c = c + 1
            nray(c, 1) = k
        End If
        For Each p In Dic(k)
            c = c + 1
            nray(c, 1) = k
            nray(c, 2) = p
            nray(c, 3) = Dic(k)(p)
        Next p
    Next k
    Dic.RemoveAll
Next Ac
With Sheets("sheet2").Range("a1").Resize(c, 3)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
    .HorizontalAlignment = xlCenter
End With
End Sub
Hello mart37 thanks for taking the time to help me. However it seems the code gives me the description of both the parent and the child and I would like to only have the Child Description. is it possible for you to adjust it?
 

Carl_H

New Member
Joined
Sep 16, 2014
Messages
18
Hello mart37 thanks for taking the time to help me. However it seems the code gives me the description of both the parent and the child and I would like to only have the Child Description. is it possible for you to adjust it?
Or rather it gives the the description of all levels for that specific child.

So instead of having it like this (my current output)

1610545400826.png


I want the output to be like this.
1610545527821.png
 

mart37

Well-known Member
Joined
Aug 4, 2017
Messages
1,090
Office Version
  1. 2016
Platform
  1. Windows
change the row: Dic(Ray(n, col(Ac))).Add (Ray(n, col(Ac + 1))), Ray(n, col(Ac + 1) + 1)
 

Watch MrExcel Video

Forum statistics

Threads
1,129,300
Messages
5,635,398
Members
416,856
Latest member
silentir

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
Top