Organize Level Hierarchy into Source-Target List

[xdulin]

I have 2 columns populated, where one column indicates the Level or Tier of the elements Named in the 2nd column. From these 2 columns, I'm trying to generate a Source-Target list as shown in the image. The tan highlighted grid is simply a visualization and may not be a necessary step in generating the Source-Target list from the Level and Name columns.

 

[Cubist]

Try on a copy. Assume data is in Column A and B. Outputing to Column D.

Sub Levels()
    Dim a, b()
    Dim i As Long, j As Long, k As Long, numRow As Long
    Dim ws As Worksheet
    Dim rng As Range
    Set ws = ThisWorkbook.Worksheets("Sheet2") 'change sheet as needed
    numRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    a = ws.Range("A1:B" & numRow).Value
    k = 1

    ReDim b(1 To numRow * numRow, 1 To 3)
    For i = 2 To numRow
        For j = i + 1 To numRow
            If a(i, 1) + 1 = a(j, 1) Then
                b(k, 1) = a(i, 2)
                b(k, 2) = a(j, 2)
                b(k, 3) = a(i, 1)
                k = k + 1
            End If
        Next j
    Next i

    Set rng = ws.Range("D2").Resize(k - 1, 3)
    rng.Value = b
   
    ' Sort by levels (column 3 in ascending order)
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add key:=rng.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange rng
        .Header = xlNo
        .MatchCase = False
        .Apply
    End With

    b = ws.Range("D2").Resize(k - 1, 3).Value
    rng.Value = b
End Sub

 

[xdulin]

Try on a copy. Assume data is in Column A and B. Outputing to Column D.

Sub Levels()
    Dim a, b()
    Dim i As Long, j As Long, k As Long, numRow As Long
    Dim ws As Worksheet
    Dim rng As Range
    Set ws = ThisWorkbook.Worksheets("Sheet2") 'change sheet as needed
    numRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    a = ws.Range("A1:B" & numRow).Value
    k = 1

    ReDim b(1 To numRow * numRow, 1 To 3)
    For i = 2 To numRow
        For j = i + 1 To numRow
            If a(i, 1) + 1 = a(j, 1) Then
                b(k, 1) = a(i, 2)
                b(k, 2) = a(j, 2)
                b(k, 3) = a(i, 1)
                k = k + 1
            End If
        Next j
    Next i

    Set rng = ws.Range("D2").Resize(k - 1, 3)
    rng.Value = b
  
    ' Sort by levels (column 3 in ascending order)
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add key:=rng.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange rng
        .Header = xlNo
        .MatchCase = False
        .Apply
    End With

    b = ws.Range("D2").Resize(k - 1, 3).Value
    rng.Value = b
End Sub

Hi Cubist,

Thanks for this.

This code almost gets there. Except that, if a Thing_# has a Level that falls underneath a preceding Level, it shouldn't be listed again in the Source-Target list.

From the image:
Thing_1 -> Thing_2
Thing_1 -> Thing_15
Thing_2 -> Thing_3
Thing_2 -> Thing_6
Thing_2 -> Thing_7
Thing_2 -> Thing_14
Thing_15 -> Thing_16
Thing_15 -> Thing_17

Note: Thing_2 should not trace to Thing_16, 17 as they both are to fall under Thing_15.

Much appreciated.

 

[Cubist]

Ok, how about this?

Sub Levels()
    Dim a, b()
    Dim i As Long, j As Long, k As Long, numRow As Long
    Dim ws As Worksheet
    Dim rng As Range
    Set ws = ThisWorkbook.Worksheets("Sheet5") 'change sheet as needed
    numRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    a = ws.Range("A1:B" & numRow).Value
    k = 1

    ReDim b(1 To numRow * numRow, 1 To 3)
    For i = 2 To numRow
        For j = i + 1 To numRow
            If a(i, 1) = a(j, 1) Then
                Exit For
            Else
                If a(i, 1) + 1 = a(j, 1) Then
                    b(k, 1) = a(i, 2)
                    b(k, 2) = a(j, 2)
                    b(k, 3) = a(i, 1)
                    k = k + 1
                End If
            End If
        Next j
    Next i

    Set rng = ws.Range("D2").Resize(k - 1, 3)
    rng.Value = b
  
    ' Sort by levels (column 3 in ascending order)
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add key:=rng.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange rng
        .Header = xlNo
        .MatchCase = False
        .Apply
    End With

    b = ws.Range("D2").Resize(k - 1, 3).Value
    rng.Value = b
End Sub

This is what I'm getting.

Book1.xlsb
	A	B	C	D	E	F	G
1	Level	Name
2	1	Thing_1		Thing_1	Thing_2	1
3	2	Thing_2		Thing_1	Thing_15	1
4	3	Thing_3		Thing_2	Thing_3	2
5	4	Thing_4		Thing_2	Thing_6	2
6	4	Thing_5		Thing_2	Thing_7	2
7	3	Thing_6		Thing_2	Thing_14	2
8	3	Thing_7		Thing_15	Thing_16	2
9	4	Thing_8		Thing_15	Thing_17	2
10	5	Thing_9		Thing_3	Thing_4	3
11	5	Thing_10		Thing_3	Thing_5	3
12	6	Thing_11		Thing_7	Thing_8	3
13	5	Thing_12		Thing_7	Thing_13	3
14	4	Thing_13		Thing_17	Thing_18	3
15	3	Thing_14		Thing_8	Thing_9	4
16	2	Thing_15		Thing_8	Thing_10	4
17	3	Thing_16		Thing_8	Thing_12	4
18	3	Thing_17		Thing_18	Thing_19	4
19	4	Thing_18		Thing_10	Thing_11	5
20	5	Thing_19		Thing_19	Thing_20	5
21	6	Thing_20		Thing_20	Thing_21	6
22	7	Thing_21
Sheet5

 

[xdulin]

Ok, how about this?

Sub Levels()
    Dim a, b()
    Dim i As Long, j As Long, k As Long, numRow As Long
    Dim ws As Worksheet
    Dim rng As Range
    Set ws = ThisWorkbook.Worksheets("Sheet5") 'change sheet as needed
    numRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    a = ws.Range("A1:B" & numRow).Value
    k = 1

    ReDim b(1 To numRow * numRow, 1 To 3)
    For i = 2 To numRow
        For j = i + 1 To numRow
            If a(i, 1) = a(j, 1) Then
                Exit For
            Else
                If a(i, 1) + 1 = a(j, 1) Then
                    b(k, 1) = a(i, 2)
                    b(k, 2) = a(j, 2)
                    b(k, 3) = a(i, 1)
                    k = k + 1
                End If
            End If
        Next j
    Next i

    Set rng = ws.Range("D2").Resize(k - 1, 3)
    rng.Value = b
 
    ' Sort by levels (column 3 in ascending order)
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add key:=rng.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange rng
        .Header = xlNo
        .MatchCase = False
        .Apply
    End With

    b = ws.Range("D2").Resize(k - 1, 3).Value
    rng.Value = b
End Sub

This is what I'm getting.

Book1.xlsb
	A	B	C	D	E	F	G
1	Level	Name
2	1	Thing_1		Thing_1	Thing_2	1
3	2	Thing_2		Thing_1	Thing_15	1
4	3	Thing_3		Thing_2	Thing_3	2
5	4	Thing_4		Thing_2	Thing_6	2
6	4	Thing_5		Thing_2	Thing_7	2
7	3	Thing_6		Thing_2	Thing_14	2
8	3	Thing_7		Thing_15	Thing_16	2
9	4	Thing_8		Thing_15	Thing_17	2
10	5	Thing_9		Thing_3	Thing_4	3
11	5	Thing_10		Thing_3	Thing_5	3
12	6	Thing_11		Thing_7	Thing_8	3
13	5	Thing_12		Thing_7	Thing_13	3
14	4	Thing_13		Thing_17	Thing_18	3
15	3	Thing_14		Thing_8	Thing_9	4
16	2	Thing_15		Thing_8	Thing_10	4
17	3	Thing_16		Thing_8	Thing_12	4
18	3	Thing_17		Thing_18	Thing_19	4
19	4	Thing_18		Thing_10	Thing_11	5
20	5	Thing_19		Thing_19	Thing_20	5
21	6	Thing_20		Thing_20	Thing_21	6
22	7	Thing_21
Sheet5

This looks to be working Cubist!

Very much appreciated,
Xavier

 

[Cubist]

You're welcome. Glad to help. Cheers.