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

Hi, I'm new to Excel and VBA. I'm trying to learn on my own but have yet to find a answer for a way to accomplish what I'm trying to do.

I have one sheet in column(A) I have multiple words in different cells. In my example it is names and fruits.
I want to be able to separate the words into there own separate sheet if the word appears.
I also need it to separate the words into a different column in its appropriate sheet if a blank cell is shown.

I'm attach a example excel file.

In my example in column A-

Bill

Bob

Kiwi

Hank

Harry

Fred

Bill

Apple

Kiwi

Hank

Harry

Mike

Orange

John

Fred

I need Bill, Bob, Hank, Harry, Fred to go to a sheet named 'Names" into column A - Kiwi Will go to its own separate sheet named "Fruit" in column A
Because there is a blank cell in between my information. I need to to move over a column in their appropriate sheets
Bill, Hank, Harry will go to sheets named "names" and now to column B. Apple, and Kiwi will move to Sheet "Fruit" and into column B
Mike, John Fred- Sheet "Names" Column C. Orange to sheet "Fruit" column C.

I need this to continue on for as long as possible because I don't know how much information I will have in the original sheet where all there information is in Column A.

I hope how I'm explaining this makes sense, and I'm sure will all your bright minds, someone will be able to tackle this challenge for me.

Thanks

Although it's quite easy for us humans to tell the diffrence between fruit and names. the computer hasn't a hope without complete lists of what are names and what are fruit.
I say quite easy; but it isn't necessarily that easy; what do you do with the likes of Cherry, Apple (Gyneth Paltrow daughter), Olive, Huckleberry (Finn), Kiwi, Damson, Cerise, Peach, Clementine (Churchill), all of which are names and fruit?
Another way is to mark (in an adjcent column in Sheet1) those items which are names, or those which are fruit.. or both.

Quote:

---

Originally Posted by p45cal

Although it's quite easy for us humans to tell the diffrence between fruit and names. the computer hasn't a hope without complete lists of what are names and what are fruit.

---

I might have goofed here; could the sheet tab List be those lists? or is that sheet to be generated too?

p45Cal, I understand what you're saying, In the attached file called example I have a separate sheet called list. This sheet has dedicated list for names and fruit. I figured excel would be able to tell if information came from these set list.

p45cal, you're correct I just named the sheet as list. In my real excel it is called inputs.

The list will not need to be generated as I will be providing that information

Code:

---

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.

Another way, this bumps the output over a column each time it finds a blank in the data

Code:

---

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

---

WOW THANK YOU this is exactly what I needed.

Trace through the code and comments (P45Cal's and mine) to learn and understand

There are more efficient (probably) ways to do a lot of this, but I opted for straight-forwardness (assuming that's a word). P45cal's is more concise and possibly more efficient

Use [Thread Tools] above your first post to make it [Solved] if there's nothing more

Attachment 19556Thanks, I will make sure to mark it as solved as soon as I figure out how to get it to work in my exact excel spreadsheet. I hate to make people do my work and I want to learn, that is why I just used a example sheet. I'm currently trying to get it to work in my sheet. Once I get it to work I will mark this as solved. Until then you both have been very helpful and I would like to keep it open for a little while I get this worked out. Cheers

I'm going to post my exact sheet and maybe if you guys find time can take a look at it and it might speed up my questions in the future as I'm trying to add my own sheets to the code you both have wrote.

In my sheet. Recipes that is what I was using in my example sheet 1. I need column A to move to Either Grain2, Hop2 or Other2. I'm using the list used on the sheet called Inputs for my list.

I have yet to get this to work using my original spreadsheet. Would either of you be willing to help?

Code:

---

Sub MoveData()
    Sheets("Grain2").Cells.ClearContents
    Sheets("Hop2").Cells.ClearContents
   
    DestnColumn = 1
    For Each are In Sheets("Recipe").Columns(1).SpecialCells(xlCellTypeConstants, 2).Areas
        'are.Select
        GrainDestnRow = 1: HopDestnRow = 1
        For Each cll In are.Columns(1).Cells'deals with he merged cells (try not to use merged cells with VBA - they're very hard work!)
            'cll.Select
            CurrentItem = Application.Trim(cll.Value)
            Set GrainFound = Sheets("Inputs").Columns(1).Find(what:=CurrentItem, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
            If Not GrainFound Is Nothing Then
                Sheets("Grain2").Cells(GrainDestnRow, DestnColumn) = CurrentItem
                GrainDestnRow = GrainDestnRow + 1
            End If
            Set HopsFound = Sheets("Inputs").Columns(3).Find(what:=CurrentItem, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
            If Not HopsFound Is Nothing Then
                Sheets("Hop2").Cells(HopDestnRow, DestnColumn) = CurrentItem
                HopDestnRow = HopDestnRow + 1
            End If
        Next cll
        DestnColumn = DestnColumn + 1
    Next are
End Sub

---

Problems:
Merged columns A and B in Recipe sheet
Several syntax errors (Recipe instead of Sheets)
Names of variables not consistent.

For this last, I should have included some Dim statements at the top of the sub's code as well as a single Option Explicit line at the top of the code module:

Code:

---

Dim DestnColumn, are, GrainDestnRow, HopDestnRow, cll, CurrentItem, GrainFound, HopsFound

---

and this would have shown up spelling differences.

Thank you. I will try it right after dinner.

Some of the problems highlighted:

Sub MoveData()
Sheets("Grain2").Cells.ClearContents
Sheets("Hop2").Cells.ClearContents

DestnColumn = 1
For Each are In Recipe("Recipe").Columns(1).SpecialCells(xlCellTypeConstants, 2).Areas
'are.Select
Grain2DestnRow = 1: Hop2DestnRow = 1
For Each cll In are.Cells
'cll.Select
CurrentItem = Application.Trim(cll.Value)
Set GrainFound = Recipe("Inputs").Columns(1).Find(what:=CurrentItem, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
If Not GrainFound Is Nothing Then
Sheets("Grain2").Cells(GrainDestnRow, DestnColumn) = CurrentItem
GrainDestnRow = GrainDestnRow + 1
End If
Set HopsFound = Recipe("Inputs").Columns(3).Find(what:=cll.Value, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False) 'my mistake:cll.value should be CurrentItem, but it wouldn't have mattered.
If Not HopsFound Is Nothing Then
Sheets("Hops2").Cells(HopsDestnRow, DestnColumn) = CurrentItem
HopsDestnRow = HopsDestnRow + 1
End If
Next cll
DestnColumn = DestnColumn + 1
Next are
End Sub

End Sub


How many columns will you be searching (curtrently only 2)? If more than 4 then there's probably some shorter code we can use.

Currently I'm only search 3 columns I go to a fourth but no more than 4

I tried adding Others to search list and put data into sheet others2.
Your code worked perfectly for search the 2 columns but when I added a third I did something wrong. I keep getting a error.
Below is what code I have and I made BOLD and Underlined what the debugger is saying is the issue.
Another question I have is are my sheet names and my list names to similar that it is making vba work harder?
I also unmerged cell a and b on the recipe sheet.
Thanks Again

Sub MoveData()
Sheets("Grain2").Cells.ClearContents
Sheets("Hop2").Cells.ClearContents
Sheets("Other2").Cells.ClearContents

DestnColumn = 1
For Each are In Sheets("Recipe").Columns(1).SpecialCells(xlCellTypeConstants, 2).Areas
'are.Select
GrainDestnRow = 1: HopDestnRow = 1
For Each cll In are.Columns(1).Cells 'deals with he merged cells (try not to use merged cells with VBA - they're very hard work!)
'cll.Select
CurrentItem = Application.Trim(cll.Value)
Set GrainFound = Sheets("Inputs").Columns(1).Find(what:=CurrentItem, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
If Not GrainFound Is Nothing Then
Sheets("Grain2").Cells(GrainDestnRow, DestnColumn) = CurrentItem
GrainDestnRow = GrainDestnRow + 1
End If
Set HopsFound = Sheets("Inputs").Columns(3).Find(what:=CurrentItem, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
If Not HopsFound Is Nothing Then
Sheets("Hop2").Cells(HopDestnRow, DestnColumn) = CurrentItem
HopDestnRow = HopDestnRow + 1
End If
Set OthersFound = Sheets("Inputs").Columns(5).Find(what:=CurrentItem, lookat:=xlWhole, LookIn:=xlFormulas, searchformat:=False)
If Not OthersFound Is Nothing Then
Sheets("Other2").Cells(OthersDestnRow, DestnColumn) = CurrentItem
OthersDestnRow = OthersDestnRow + 1
End If
Next cll
DestnColumn = DestnColumn + 1
Next are
End Sub

Just saw what you said about errors. Should I rename the sheet named "Recipe" back to Sheet?
Change sheet names that are too close to list named on input sheet?

After Some playing around I got it to work. Thanks Again!!!!!!

Sheet names and variable names are fine as they are.
Change:
GrainDestnRow = 1: HopDestnRow = 1
To:
GrainDestnRow = 1: HopDestnRow = 1: OthersDestnRow = 1
(Not near a computer at the moment)