Sub LinkSort()
Dim lRow As Long, match As Long, noIDs As Long, iD As Long, idPos As Long, cRow As Long, endLoop As Long
Dim multIDs As Long
Dim str As String, replaced As String, LnkID As String
Dim rng As Range
'Get last row of data in column "A"
lRow = Cells(Rows.Count, 1).End(xlUp).Row
'Set r to the data in column "A" so we can search for LinkTo ID's
Set rng = Range(Cells(1, 1), Cells(lRow, 1))
'Set loop variables
endLoop = rng.Rows.Count
cRow = 2
multIDs = 0
'Loop through the data and find a match for the LinkTo ID
While cRow <= endLoop
str = Cells(cRow, "N").Value
replaced = Replace(str, "-", "")
noIDs = Len(str) - Len(replaced)
Select Case noIDs
Case Is = 1 'Move the item below the matching LinkTo ID
On Error Resume Next 'in case no match found match = 0
match = Application.match(Cells(cRow, "N").Value, rng, 0) + 1
If match <> 0 And cRow <> match Then
On Error GoTo 0
Rows(cRow & ":" & cRow).Cut
Rows(match & ":" & match).Insert Shift:=xlDown
If match > rng.Rows.Count Then ' if match + 1 is greater than the number of rows we need to extend the range by 1 row
Set rng = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
End If
match = 0
Else
cRow = cRow + 1
match = 0
End If
Case Is > 1 'Move the item to the bottom of the list and increment multIDs and reduce endLoop by 1
multIDs = multIDs + 1
Rows(cRow & ":" & cRow).Cut
Rows(Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Insert Shift:=xlDown
Set rng = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
endLoop = endLoop - 1
match = 0
Case Is = 0 'No Id indicates bad data so we will skip this item
cRow = cRow + 1
match = 0
End Select
On Error GoTo 0
Wend
'Here is where we will deal with all the items with multiple LinkTo ids
If multIDs <> 0 Then
cRow = endLoop + 1
endLoop = endLoop + multIDs
For cRow = cRow To endLoop
str = Cells(cRow, "N").Value
replaced = Replace(str, "-", "")
noIDs = Len(str) - Len(replaced)
Rows(cRow & ":" & cRow).Copy
Rows(cRow + 1 & ":" & cRow + noIDs - 1).Insert Shift:=xlDown
Application.CutCopyMode = False
Set rng = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
endLoop = endLoop + noIDs - 1
LnkID = Cells(cRow, "N").Value
idPos = 0
For iD = 1 To noIDs
idPos = InStr(idPos + 1, LnkID, "-", vbTextCompare)
If idPos <> 0 Then
On Error Resume Next
match = Application.match(Mid(LnkID, idPos - 4, 6), rng, 0)
If match <> 0 And cRow <> match + 1 Then
On Error GoTo 0
Rows(cRow & ":" & cRow).Cut
Rows(match + 1 & ":" & match + 1).Insert Shift:=xlDown
If cRow > match + 1 Then cRow = cRow + 1
End If
End If
Next iD
Next cRow
End If
End Sub
