Need Help Wrting This. (If from list, Then, If blanks, New Column)

[p45cal]

Sub blah()
Sheets("Names").Cells.ClearContents
Sheets("Fruit").Cells.ClearContents

DestnColumn = 1
For Each are In Sheets("Sheet1").Columns(1).SpecialCells(xlCellTypeConstants, 2).Areas
  'are.Select
  NameDestnRow = 1: FruitDestnRow = 1
  For Each cll In are.Cells
    'cll.Select
    CurrentItem = Application.Trim(cll.Value)
    Set NameFound = Sheets("List").Columns(1).Find(what:=CurrentItem, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
    If Not NameFound Is Nothing Then
      Sheets("Names").Cells(NameDestnRow, DestnColumn) = CurrentItem
      NameDestnRow = NameDestnRow + 1
    End If
    Set FruitFound = Sheets("List").Columns(3).Find(what:=cll.Value, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
    If Not FruitFound Is Nothing Then
      Sheets("Fruit").Cells(FruitDestnRow, DestnColumn) = CurrentItem
      FruitDestnRow = FruitDestnRow + 1
    End If
  Next cll
  DestnColumn = DestnColumn + 1
Next are
End Sub

You have a trailing space after the name Bob in Sheet1 (And Hank appears twice, once with a trailing space and once without!). This doesn't matter as I've included Application.Trim in the code, however, it's important that the List sheet entries contain no leading/trailing spaces, otherwise things may not be found.