I modified the above code to protect against one form of sloppy typing...
extra blank spaces. This code should handle that problem...

Sub GetAssignments(Cell As Range, Phrase As String)
Dim X As Long
Dim Contents As String
Dim Fields() As String
Dim Words() As String
Contents = Replace(Range("A1").Text, vbLf, " ")
Do While InStr(Contents, " ")
Contents = Replace(Contents, " ", " ")
Loop
Fields = Split(Contents, Phrase)
For X = 1 To UBound(Fields)
Words = Split(Trim$(Fields(X)), " ")
Cell.Offset(0, X).Value = Words(0) & " " & Words(1)
Next
End Sub

For the archive record... there is an error in the above code... I
accidentally left a hard-coded reference in the Range statement in the first
line of code after the Dim statements. The "A1" reference should have been a
reference to the passed in Cell argument. Here is the corrected code...

Sub GetAssignments(Cell As Range, Phrase As String)
Dim X As Long
Dim Contents As String
Dim Fields() As String
Dim Words() As String
Contents = Replace(Cell.Text, vbLf, " ")
Do While InStr(Contents, " ")
Contents = Replace(Contents, " ", " ")
Loop
Fields = Split(Contents, Phrase)
For X = 1 To UBound(Fields)
Words = Split(Trim$(Fields(X)), " ")
Cell.Offset(0, X).Value = Words(0) & " " & Words(1)
Next
End Sub


Rick