Sub LinkSort()
Dim lRow As Long, remRow As Long, i As Long, j As Long
Dim str As String, strFirstAddress As String
Dim rng As Range, c As Range
Dim idFound As Boolean
Dim idArr As Variant
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Set ws = ActiveSheet
'Get last row of data in column "A"
lRow = Cells(Rows.Count, 1).End(xlUp).Row
remRow = lRow
'Sort data twice by col W. Once descending to push all x's to the bottom and then again to sort remaining y's and z's ascending and alpha
i = 1
Do
Set rng = Range(Cells(2, 1), Cells(remRow, 24))
With ws
.Sort.SortFields.Clear
If i < 2 Then
.Sort.SortFields.Add2 Key:=Range("W2:W" & remRow) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
Else
.Sort.SortFields.Add2 Key:=Range("W2:W" & remRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End If
.Sort.SortFields.Add2 Key:=Range("H2:H" & remRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With ws.Sort
.SetRange rng
.Apply
End With
i = i + 1
If i <= 2 Then
Set c = Range("W2:W" & lRow).Find("x", , xlValues, xlWhole)
remRow = c.Row - 1
End If
Loop While i <= 2
'Set r to the data in column "A" so we can search for LinkTo ID's
Set rng = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
i = 2
idFound = False
While i <= remRow
' Debug.Print remRow
' Debug.Print i
idArr = Split(Cells(i, 14).Value, Chr(10))
For j = 0 To UBound(idArr)
With rng
Set c = .Find(idArr(j), , xlValues, xlWhole)
If Not c Is Nothing Then
If c.Row = i Then GoTo SkipError
idFound = True
strFirstAddress = c.Address
Do
Rows(i & ":" & i).Copy
Rows(c.Row + 1 & ":" & c.Row + 1).Insert Shift:=xlDown
Set rng = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
Set c = .FindNext(c)
Loop Until c.Address = strFirstAddress
End If
End With
strFirstAddress = ""
SkipError:
Next j
If Not idFound Then
i = i + 1
Else
Rows(i & ":" & i).EntireRow.Delete
remRow = remRow - 1
End If
idFound = False
Wend
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
