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
Bookmarks