Another way, this bumps the output over a column each time it finds a blank in the data
Option Explicit
Sub MoveData()
Dim wsList As Worksheet, wsNames As Worksheet, wsFruits As Worksheet, wsData As Worksheet
Dim rNames As Range, rFruits As Range, rData As Range
Dim colNames As Long, colFruit As Long ' columns to put the data in
Dim rowIndex As Long
Dim rDestination As Range
'init (need Set keyword for objects)
Set wsList = Worksheets("List")
Set wsNames = Worksheets("Names")
Set wsFruits = Worksheets("Fruit")
Set wsData = Worksheets("Sheet1")
Set rNames = wsList.Columns(1)
Set rFruits = wsList.Columns(3)
'A1 to the LAST cell in col A on the sheet up to the first non-blank cell (or A17)
Set rData = Range(wsData.Cells(1, 1), wsData.Cells(wsData.Rows.Count, 1).End(xlUp))
'clear all old data
wsNames.Cells(1, 1).CurrentRegion.ClearContents
wsFruits.Cells(1, 1).CurrentRegion.ClearContents
colNames = 1
colFruit = 1
Application.ScreenUpdating = False
'clean the data -- you have trailing blanks in some
For rowIndex = 1 To rNames.Cells(1, 1).CurrentRegion.Rows.Count
rNames.Cells(rowIndex, 1).Value = Trim(rNames.Cells(rowIndex, 1).Value)
Next rowIndex
For rowIndex = 1 To rFruits.Cells(1, 1).CurrentRegion.Rows.Count
rFruits.Cells(rowIndex, 1).Value = Trim(rFruits.Cells(rowIndex, 1).Value)
Next rowIndex
For rowIndex = 1 To rData.Rows.Count
rData.Cells(rowIndex, 1).Value = Trim(rData.Cells(rowIndex, 1).Value)
Next rowIndex
'go down rData
With rData ' anything that starts with a 'dot' 'belongs' to this
For rowIndex = 1 To .Rows.Count
'if blank move over one column
If Len(.Cells(rowIndex, 1).Value) = 0 Then
colNames = colNames + 1
colFruit = colFruit + 1
Else
'is it in the Names list?
If Not IsError(Application.Match(.Cells(rowIndex, 1).Value, rNames, 0)) Then
Set rDestination = wsNames.Cells(wsNames.Rows.Count, colNames).End(xlUp)
'if blank this is top row, if not blank then go one down
If Len(rDestination.Value) > 0 Then Set rDestination = rDestination.Offset(1, 0)
rDestination.Value = .Cells(rowIndex, 1).Value
'is it in the Fruit list?
ElseIf Not IsError(Application.Match(.Cells(rowIndex, 1).Value, rFruits, 0)) Then
Set rDestination = wsFruits.Cells(wsFruits.Rows.Count, colNames).End(xlUp)
'if blank this is top row, if not blank then go one down
If Len(rDestination.Value) > 0 Then Set rDestination = rDestination.Offset(1, 0)
rDestination.Value = .Cells(rowIndex, 1).Value
Else
MsgBox .Cells(rowIndex, 1).Value & " not a Name or Fruit"
End If
End If
Next rowIndex
End With
Application.ScreenUpdating = True
MsgBox "All Done"
End Sub