Sort/Arrange Rows based on Cell Value in Range VBA

[crp]

I have a series of data compiled into one excel sheet. The order of the data depends on each row's association to other rows, based on their LinkTo values. Below is an example of before, and how I need the data to be organized. I'd like for this to be automated in VBA.

Example Raw Data

ID	Category	LinkTo
1	Fruit
2	Onion	4
3	Apple	1
4	Vegetable
5	Banana	1
6	Red Apple	3

Example Desired Result

ID	Category	LinkTo
1	Fruit
3	Apple	1
6	Red Apple	3
5	Banana	1
4	Vegetable
2	Onion	4

 

[Crystalyzer]

Give this a go.

Assumptions:
1. Data has headers in row 1
2. Data begins in A2

Sub LinkSort()
    Dim lRow As Long, m As Long
    Dim r As Range
    Dim ws As Worksheet
       
    Set ws = ActiveSheet
   
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
   
    Set r = Range(Cells(2, 1), Cells(lRow, 3))
   
    With ws
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("C2:C" & lRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
   
    Set r = Range(Cells(2, 1), Cells(lRow, 1))
   
    While Cells(2, 3).Value <> ""
        m = Application.Match(Cells(2, 3).Value, r, 0) + 2
        Rows("2:2").Cut
        Rows(m & ":" & m).Insert Shift:=xlDown
    Wend
   
End Sub

 

[Crystalyzer]

Give this a go.

Assumptions:
1. Data has headers in row 1
2. Data begins in A2

Sub LinkSort()
    Dim lRow As Long, m As Long
    Dim r As Range
    Dim ws As Worksheet
    
    Set ws = ActiveSheet
 
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
 
    Set r = Range(Cells(1, 1), Cells(lRow, 3))
 
    With ws
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("C2:C" & lRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
 
    Set r = Range(Cells(2, 1), Cells(lRow, 1))
 
    While Cells(2, 3).Value <> ""
        m = Application.Match(Cells(2, 3).Value, r, 0) + 2
        Rows("2:2").Cut
        Rows(m & ":" & m).Insert Shift:=xlDown
    Wend
 
End Sub

slight change to the code Set r = Range(Cells(1, 1), Cells(lRow, 3)) Need to include the headers in the initial range for sorting.

 

[crp]

I think it's close, but it isn't quite working for my dataset. For my data, there are 24 columns of information A:X. The LinkTo column is N, and it is referencing column A (ID). I should've mentioned before that it's possible for some cells in the N column to have multiple links. I'm not sure how that may change the code.

 

[Crystalyzer]

Please post a copy of your data using the XL2BB tool.

 

[crp]

Unfortunately I can't provide the actual data, but the example attached illustrates the same format. I've expanded the raw data tab a little, which is a similar layout to my data. The Desired Layout tab is what I'm trying to achieve. Note that since the tomato was tagged for both categories, it was copied and placed twice in the spreadsheet. The end state is that the resulting spreadsheet will depict traceability through the category hierarchy.

Thank you for your help so far.

Raw Data

Desired Layout

 

[Crystalyzer]

Is there a delimiter between the LinkTo ID's when there are more than one or is it just a space or new line?

 

[crp]

Is there a delimiter between the LinkTo ID's when there are more than one or is it just a space or new line?

It is just a new line within the cell.

 

[Crystalyzer]

Please test this

Sub LinkSort()
    Dim lRow As Long, m As Long, n As Long, i As Long
    Dim r As Range
    Dim wb As Workbook
    Dim str As String, replaced As String, Lnks As String
    
    Set ws = ActiveSheet
    
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Set r = Range(Cells(1, 1), Cells(lRow, "N"))
    
    With ws
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("N2:N" & lRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange r
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
    Set r = Range(Cells(2, 1), Cells(lRow, 1))
    
    While Cells(2, "N").Value <> ""
        str = Cells(2, "N").Value
        replaced = Replace(str, "-", "")
        n = Len(str) - Len(replaced)
        If n <= 1 Then
            m = Application.Match(Cells(2, "N").Value, r, 0) + 2
            Rows("2:2").Cut
            Rows(m & ":" & m).Insert Shift:=xlDown
            If m > r.Rows.Count Then
                Set r = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
            End If
        Else
            Rows("2:2").Copy
            Rows("3:" & 3 + n - 2).Insert Shift:=xlDown
            Application.CutCopyMode = False
            Set r = Range(Cells(2, 1), Cells(lRow + n - 1, 1))
            Lnks = Cells(2, "N").Value
            For i = 0 To n - 1
                j = InStr(i + 5, Lnks, "-", vbTextCompare)
                m = Application.Match(Mid(Lnks, j - 4, 6), r, 0) + 2
                Rows("2:2").Cut
                Rows(m & ":" & m).Insert Shift:=xlDown
                If m > r.Rows.Count Then
                    Set r = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
                End If
            Next i
        End If
    Wend
    
End Sub

 

[crp]

Yes this worked on the example data, thank you. Which variable needs to be adjusted if the rows are colored? After I ran it, it appeared columns O through X did not adjust.