Sub lqxs()
Dim i&, Arr, d, d1, k, t, x$, j&, a$, b$, n&
Dim t1, t2, aa, c%, bb, Brr
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
[b3:c5000].Clear
Arr = [f2].CurrentRegion: n = UBound(Arr) - 1
ReDim Brr(1 To UBound(Arr) - 1, 1 To 2)
For i = 1 To UBound(Arr)
    For j = 1 To UBound(Arr, 2)
        If Arr(i, j) <> "" Then
            d(j) = d(j) & i & ",": Exit For
        End If
    Next
Next
k = d.keys: t = d.items
For c = UBound(k) To 1 Step -1
    t1 = Left(t(c - 1), Len(t(c - 1)) - 1)
    t2 = Left(t(c), Len(t(c)) - 1)
    If InStr(t2, ",") Then
        bb = Split(t2, ",")
        For j = UBound(bb) To 0 Step -1
            If InStr(t1, ",") Then
                aa = Split(t1, ",")
                For i = UBound(aa) To 0 Step -1
                    If Val(bb(j)) > Val(aa(i)) Then
                        Brr(n, 1) = Arr(aa(i), k(c - 1))
                        Brr(n, 2) = Arr(bb(j), k(c)): n = n - 1
                        Exit For
                    End If
                Next
            Else
                Brr(n, 1) = Arr(t1, k(c - 1))
                Brr(n, 2) = Arr(bb(j), k(c)): n = n - 1
            End If
        Next
    Else
        If InStr(t1, ",") Then
            aa = Split(t1, ",")
            For i = UBound(aa) To 0 Step -1
                If Val(t2) > Val(aa(i)) Then
                    Brr(n, 1) = Arr(aa(i), k(c - 1))
                    Brr(n, 2) = Arr(t2, k(c)): n = n - 1
                    Exit For
                End If
            Next
        Else
            Brr(n, 1) = Arr(t1, k(c - 1))
            Brr(n, 2) = Arr(t2, k(c)): n = n - 1
        End If
    End If
Next
[b3].Resize(UBound(Brr), 2) = Brr
[b3].Resize(UBound(Brr), 2).Borders.LineStyle = 1
End Sub