Sub DeleteIfNotTransfer()
Dim lR As Long, R As Range, vA As Variant, dRws As Range, i As Long
lR = Range("B" & Rows.Count).End(xlUp).Row
Set R = Range("B2:B" & lR)
vA = R.Value
For i = LBound(vA, 1) To UBound(vA, 1)
If Not InStr(1, UCase(vA(i, 1)), "TRANSFER") = 1 Then
If Not dRws Is Nothing Then
Set dRws = Union(dRws, R.Cells(i))
Else
Set dRws = R.Cells(i)
End If
End If
Next i
Application.ScreenUpdating = False
If Not dRws Is Nothing Then dRws.EntireRow.Delete
Application.ScreenUpdating = True
End Sub