Define parent/child relationship in two columns from data table

[Marcus131975]

Hello

Id be really grateful if anyone is able to tell me how to solve the following in VBA:

I need to extract (into two columns on a separate sheet ideally) the child and parent relationship from a table of data. The table data range varies between 5 and 10 columns, with the right most column being the child and the columns to the left showing the various parent up to the top parent. I am only concerned with the immediate parent of each value and any duplicates should be ignored.

Hopefully the below example might help explain this. Thank you.

Before

Book1
	A	B	C	D
1	A	A	A	1
2	A	A	B	2
3	A	A	D	3
4	A	B	C	4
Sheet1

Desired Result

Book1
	A	B
8	1	A
9	2	B
10	3	D
11	4	C
12	B	A
13	D	A
14	C	B
15	A
Sheet1

Marcus

 

[Peter_SSs]

This seems to work with your sample data - see how it goes with your real data. It assumes your original data is in the active sheet when the code is run.

Sub ParentChild()
  Dim a As Variant
  Dim d As Object
  Dim i As Long, j As Long, uba As Long
  
  a = Range("A1").CurrentRegion.Value
  uba = UBound(a)
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  For j = UBound(a, 2) To 2 Step -1
    For i = 1 To uba
      If a(i, j) <> a(i, j - 1) Then
        d(a(i, j)) = a(i, j - 1)
      End If
    Next i
  Next j
  For i = 1 To uba
    d(a(i, 1)) = Empty
  Next i
  Sheets.Add After:=ActiveSheet
  Range("A1").Resize(d.Count, 2).Value = Application.Transpose(Array(d.Keys, d.Items))
End Sub

 

[Marcus131975]

Thank you very much Peter, I appreciate it.

I am using this for a custom loader but noticed when I compare it to the control file that it also requires the 'position' of the child, which is stored as a number.

That number starts at 31 from the bottom (child values) and decreased by 1 for each parent.

As from my data you can see that a value can be repeated within the hierarchy in multiple columns but, from what I can see, it uses the hierarchy value from the first column it is in from left to right, if it repeats.

Hopefully the example below will help (column numbering in first table for illustration only)

	A	B	C	D

<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]
[TD="align: center"]28[/TD]
[TD="align: center"]29[/TD]
[TD="align: center"]30[/TD]
[TD="align: center"]31[/TD]

[TD="align: center"]2[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]1[/TD]

[TD="align: center"]3[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]2[/TD]

[TD="align: center"]4[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]3[/TD]

[TD="align: center"]5[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]4[/TD]

</tbody>

Sheet1​

After

	A	B	C

<colgroup><col style="width: 25pxpx"><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]8[/TD]
[TD="align: center"]1[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]31[/TD]

[TD="align: center"]9[/TD]
[TD="align: center"]2[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]31[/TD]

[TD="align: center"]10[/TD]
[TD="align: center"]3[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]31[/TD]

[TD="align: center"]11[/TD]
[TD="align: center"]4[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]31[/TD]

[TD="align: center"]12[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]29[/TD]

[TD="align: center"]13[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]30[/TD]

[TD="align: center"]14[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]30[/TD]

[TD="align: center"]15[/TD]
[TD="align: center"]A[/TD]
[TD="align: center"][/TD]
[TD="align: center"]28[/TD]

</tbody>

Sheet1​

.
If you have time, or inclination, to let me know how this could be achieved Id very grateful, but dont worry if not

Thanks again for your help
Marcus

 

[Peter_SSs]

Again, this seems to work with that new sample data & expected result.

Sub ParentChild_v2()
  Dim a As Variant
  Dim d As Object
  Dim i As Long, j As Long, uba As Long
  
  a = Range("A1").CurrentRegion.Value
  uba = UBound(a)
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  For j = UBound(a, 2) To 2 Step -1
    For i = 2 To uba
      If a(i, j) <> a(i, j - 1) Then
        d(a(i, j)) = a(i, j - 1) & "," & a(1, j)
      End If
    Next i
  Next j
  For i = 2 To uba
    d(a(i, 1)) = "," & a(1, 1)
  Next i
  Sheets.Add After:=ActiveSheet
  Range("A1").Resize(d.Count, 2).Value = Application.Transpose(Array(d.Keys, d.Items))
  Columns("B").TextToColumns DataType:=xlDelimited, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False
End Sub

 

[Marcus131975]

Thank you so much Peter, that's perfect from what I can see. You have been a big help and it is much appreciated and makes my life over the next few days a lot easier.

Thanks again
Marcus

 

[Peter_SSs]

Thank you so much Peter, that's perfect from what I can see. You have been a big help and it is much appreciated and makes my life over the next few days a lot easier.

Thanks again
Marcus

You are welcome.