Separating Sheet into different sheets based on cell "Containing" string in another sheet...

[rjbur]

Here is my challenge and I am continuing to search the forum for an example, so if there is another useful thread, please point me in that direction.

I have a spreadsheet/workbook that contains two (2) sheets. Lets call them "CRITERIA" and "DATA". I need to perpetrate the DATA into NEW sheets based on the CRITERIA and if the sheet does not exist, create it based on the Header Row in the CRITERIA sheet. If it does exist, then simply add the data to the end of the existing content in the sheet.

DATA contains a long list of... you guessed it, data. Column-A contains "text" or a string. For my example, anything past Column A is along for the ride.

Here is what the CRITERIA sheet might look like:

	A	B
1	CARS	COLOR
2	Dodge	Red
3	Chevy	Green
4	GMC	Blue

<colgroup><col><col span="2"></colgroup><tbody>
</tbody>

Now the DATA sheet contains say something like:

A B C 1 Theredrugwill… Row 1 data More Row 1 data 2 Chevycarsare… Row 2 data More Row 2 data 3 Theskyisblue… Row 3 data More Row 3 data 4 GMCTruckare… Row 4 data More Row 4 data 5 DodgePowerWagon… Row 5 data More Row 5 data 6 Thegrassisgreeneron… Row 6 data More Row 6 data <colgroup><col><col><col><col></colgroup><tbody> </tbody>

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

Note that I have purposely removed the spacing as the Column-A needs to "contain" the letters and not match a word. As long as somewhere in the cell it has the combination of characters, it contains it and the complete ROW needs to be MOVED to another sheet. If nothing matches, then it is not processed and stays in the current sheet.

In the CRITERIA sheet you can see there are now two columns with the headers of CARS and COLOR. When macro finishes I should have two new sheets, one CARS and the other COLOR.

The other twist is that should I add a third column to CRITERIA it should be processed as well. So we have two open dimensions, the size of the elements under each header and the number of headers to be processed against the DATA.

I did not add a no-match row so that it would stay in the DATA sheet...

I have to run, so I will read through this later today to make sure it makes sense.

Thanks for your time,

Rich

 

[rjbur]

I'm back... seems I cannot edit my post so...

" I need to perpetrate" should have been "I need to separate" my data....

No if it is easier I can take away the requirement that it be a dynamic macro capable of handing a growing set of headers/columns in the the CRITERIA sheet. However, I do need the list under each header in CRITERIA to be dynamic and change in size as needed.

Also, I do understand there is one more question that may come up, "What if in the DATA sheet Column-A "contains" something that matches more than one header category in the CRITERIA sheet?" Well I guess there's one easy way to deal with this and that would be on a first-come-first serve bases, meaning that the first category/header that is processed and matches dictates where the the row will be moved to. Unless someone can figure a coll way to put the row into more than one sheet, my need is still be met if its placed in the first matching criteria sheet.

I can think of a brute force method to do this, but I know there has to be a more elegant way using Excel's built in functions to deal with data. I'm just not familiar with the more advanced data functions.

Thanks again for any assistance and time...

Rich

 

[mumps]

With sheet Criteria being the active sheet, try this macro:

Sub AddSheet()
    Application.ScreenUpdating = False
    Dim lColumn As Long
    lColumn = Sheets("Criteria").Cells(1, Columns.Count).End(xlToLeft).Column
    Dim LastRow As Long
    LastRow = Sheets("Criteria").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim category As Range
    Dim val As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim ws As Worksheet
    For Each category In Sheets("Criteria").Range(Cells(1, 1), Cells(1, lColumn))
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(category.Value)
        On Error GoTo 0
        If ws Is Nothing Then
            Worksheets.Add(After:=Sheets(Sheets.Count)).Name = category.Value
            Sheets("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(LastRow, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    'sAddr = ""
                End If
            Next val
        Else
            Sheets("Criteria").Select
            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(LastRow, category.Column))
                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    sAddr = ""
                End If
            Next val
        End If
    Next category
    Application.ScreenUpdating = True
 End Sub

It should adjust for varying number of rows and columns in Criteria. It takes care of this too:

"What if in the DATA sheet Column-A "contains" something that matches more than one header category in the CRITERIA sheet?"

 

[rjbur]

OK, this is a fantastic start... It processed all items in Column-A of "Criteria" and then proceeded to try and process the empty cell after the last item. In doing so it went to the "Data" sheet and found the empty cell in column-A after the last "data" row and started coping the empty rows into the new sheet it created.... Needless to say, it seemed to be stuck while it was processing all of those empty rows. Found this as I stepped through and set a few "watch" variables.

I'm looking into it now, as I suspect it's in this slice of code, probably the "If" statement...

            For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(LastRow, category.Column))                Set foundVal = Sheets("Data").Range("A:A").Find(val, LookIn:=xlValues, lookat:=xlPart)
                If Not foundVal Is Nothing Then
                    sAddr = foundVal.Address
                    Do
                        foundVal.EntireRow.Copy Sheets(category.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                        Set foundVal = Sheets("Data").Range("A:A").FindNext(foundVal)
                    Loop While foundVal.Address <> sAddr
                    'sAddr = ""
                End If
            Next val

It should have processed the empty cell in the "Criteria" sheet as "Nothing" and thus concluded it reached the end of that Column and tried to move onto the next column.

 

[rjbur]

Wait... I just noticed that in my slice there is a line that is commented out??

[COLOR=#333333]        'sAddr = ""
[/COLOR]

Not the case in yours? Wonder how that happen when I cut-and-pasted the code in??

Trying again now..

OK, not a fix, it still jumped and is processing all of the empty cells/rows...

Further investigation...

 

[mumps]

I based the macro on the data you posted which had no empty cells. What works on sample data most often won't work on the actual data because even a minor change will make a difference. It is always easier to help and test possible solutions if we could work with your actual file. Perhaps you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do referring to specific cells and worksheets. If the workbook contains confidential information, you could replace it with generic data.

 

[rjbur]

OK, it might be at the top here the line that determines the Last Row is:

LastRow = Sheets("Criteria").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

My actual "Criteria" sheet has 3 items in the first category and 5 in the second.

That means that the Last Row in Column-A should be 4 (3+header) and for Column-B it is 6 (5+header).

Thus as it is processing Column-A it goes past the last actual item and starts processing the empty cell A5 copying all of the empty rows into the new sheet it created....

I think that is what is happening. A fix would be to determine the Last Row for each independent Column. Looking into this now...

 

[rjbur]

WOW that was a quick reply as I was typing...

Each Column in "Criteria" may have any number of items...

Thank you for such a quick reply, this is amazing... Learning much as I read through the code...

Rich

 

[rjbur]

Wait... I just noticed that in my slice there is a line that is commented out??

[COLOR=#333333]        'sAddr = ""
[/COLOR]

Not the case in yours? Wonder how that happen when I cut-and-pasted the code in??

Trying again now..

OK, not a fix, it still jumped and is processing all of the empty cells/rows...

Further investigation...

Ignore this one as it is commented in the first half of the "If" but not in the second "Else" portion.

Also, there may be more than 2 columns in the "Criteria". I'm still learning and reading...

Thanks again,

Rich

 

[mumps]

Replace this line of code (2 occurrences):

For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(LastRow, category.Column))

with this line:

For Each val In Sheets("Criteria").Range(Cells(2, category.Column), Cells(Cells(Rows.Count, category.Column).End(xlUp).Row, category.Column))

This takes into account the Last Row for each independent Column. (I hope!!)