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