Cut specific text from cells and paste in neighbour cell

Replace the existing code in module 1 with this.

Sub Extract()
Dim LastRow As Long, Y As Long, SearchTxt As String, TestVal As String

Retry:

    SearchTxt = InputBox("Enter the Search Value to be moved.", "Instr", "pridon1")
    If SearchTxt = "" Then
        Y = MsgBox("No Search text entered....... Try again ?", vbOKCancel, "ERROR")
        If Y = vbCancel Then
            Exit Sub
        Else
            GoTo Retry
        End If
    Else
        LastRow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
        For Y = 1 To LastRow
            TestVal = Sheet1.Range("A" & Y).Value
            If InStr(1, TestVal, SearchTxt, vbTextCompare) > 0 Then
                Sheet1.Range("B" & Y).Value = SearchTxt
                Sheet1.Range("A" & Y).Replace What:=SearchTxt, Replacement:=""
            End If
        Next Y
    End If

End Sub