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

[Paul_Hossler]

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