Sub SortText()
Dim LastRow As Long, i As Long, Rng As Range, x As Long, Arr()
    LastRow = Cells(Rows.Count, 7).End(xlUp).Row
    Range(Cells(2, 7), Cells(LastRow + 1, 8)).Clear
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Arr = Range(Cells(2, 2), Cells(LastRow, 2)).Value
    ReDim Arr2(1 To UBound(Arr), 1 To 2)
    For i = 1 To UBound(Arr)
        x = x + 1
        Arr2(x, 1) = Arr(i, 1)
        Set Rng = Columns(4).Find(what:=Arr(i, 1), LookIn:=xlValues, lookAt:=xlWhole)
        If Not Rng Is Nothing Then Arr2(x, 2) = Rng.Offset(0, 1)
    Next
    Range("G2").Resize(x, 2).Value = Arr2
End Sub